gcc/Changelog:

	2008-02-26  Basile Starynkevitch  <basile@starynkevitch.net>
	* Makefile.in: adding melt-private-include/ thing
	* melt/ : subdirectory moved here (was in ..)



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

4 files changed, 9028 insertions, 16 deletions

diff --git a/gcc/Makefile.in b/gcc/Makefile.in
index 1cc90cbdf33..4e775d517a2 100644
--- a/gcc/Makefile.in
+++ b/gcc/Makefile.in
@@ -285,7 +285,7 @@ ZLIBINC = @zlibinc@
 GMPLIBS = @GMPLIBS@
 GMPINC = @GMPINC@
 
-### for Basilys
+### for MELT/ Basilys 
 # How to find PPL (Parma Polyhedra Library)
 PPLLIBS = @ppllibs@
 PPLINC = @pplinc@
@@ -4497,10 +4497,56 @@ po/gcc.pot: force
 	AWK=$(AWK) $(SHELL) $(srcdir)/po/exgettext \
 		$(XGETTEXT) gcc $(srcdir)
 
-
-## definition for basilys internal compilation
+################################################################ 
+## definition for basilys/MELT internal compilation
+## see thread http://gcc.gnu.org/ml/gcc/2008-02/msg00632.html
+## in particular http://gcc.gnu.org/ml/gcc/2008-02/msg00673.html
 compile-basilys-defs:	
 	echo '#generated compile-basilys-defs' > $@
 	echo 'ALL_CFLAGS="' $(ALL_CFLAGS) '"' >> $@
 	echo 'ALL_CPPFLAGS="' -I$(PWD) $(ALL_CPPFLAGS) '"' >> $@
+
+
+
+## this is the installation directory
+melt_private_include_dir=$(libexecsubdir)/melt-private-include/
+
+## this is the local build directory
+melt_build_include_dir= melt-private-build-include
+
+# we want to generate all the direct (non system) dependencies of run-basilys.h
+# the following should work if $(CC) is some recent version of GCC (probably >= 4.x)
+
+# we first generate the make-dependencies using -MMD
+# this should write into run-basilys.d some stuff like
+## run-basilys-deps: srcdir.../gcc/run-basilys.h  config.h auto-host.h ....
+# with the srcdir... replaced by the source directory
+# however, there are also config/ files in the dependency list
+# config/ files should be handled specially since they are the only #include-d files
+# which are not flat, ie in a subdirectory, like srcdir.../gcc/config/i386/x86-64.h
+# there is also a dependency on tm.h (in objdir) which contains stuff like #include "config/i386/x86-64.h"
+run-basilys.d: run-basilys.h \
+   $(CONFIG_H) $(SYSTEM_H) $(TIMEVAR_H) $(TM_H)  $(TREE_H)  $(GGC_H)  \
+   tree-pass.h basilys.h gt-basilys.h
+	$(CC) -MT run-basilys-deps -MMD  $(ALL_CFLAGS) $(ALL_CPPFLAGS) $<
+
+.PHONY: run-basilys-deps
+## the include below defines the dependencies of run-basilys-deps
+## included file run-basilys.d is generated above
+-include run-basilys.d
+
+
+## copy all the file in the dependency of run-basilys-deps into $(melt_private_include_dir)
+## but handle the $(srcdir)/config/ files specially by copying them within a config/ directory
+run-basilys-deps:
+	$(mkinstalldirs) $(melt_build_include_dir); \
+	for f in $^ ; do \
+	  cf=`echo $$f | sed -q ":^$(srcdir)/config/:$(melt_build_include_dir)/config:"`; \
+	  if [ -n "$$cf" ] ;  then  \
+	    cp -p $$f $$cf ; \
+	  else  \
+	    cp -p $$f $(melt_build_include_dir)/ ; \
+		fi; \
+	done
+
 ### end of basilys stuff
\ No newline at end of file
diff --git a/gcc/melt/README-MELT b/gcc/melt/README-MELT
new file mode 100644
index 00000000000..c1cc59e6b3c
--- /dev/null
+++ b/gcc/melt/README-MELT
@@ -0,0 +1,95 @@
+## file melt/README.melt in melt-branch of GCC
+
+Please read the wiki page on http://gcc.gnu.org/wiki/MiddleEndLispTranslator
+and my GCC summit 2007 paper 
+Multi-stage construction of a global static analyser by Basile Starynkevitch, pages 143 - 152
+
+This directory contains melt files. MELT is a dialect of Lisp compiled
+into C code which should be compilable (by some strange basilys-gcc
+script invoking any GCC [or perhaps even another compiler?] with the
+appropriate -fPIC and -I options
+
+The MELT source files are called .bysl (sorry for the messy suffix)
+
+This basilys-gcc (which really should be named melt-gcc) should be something similar to
+########################## CUT HERE FILE basilys-gcc to be installed in your $PATH
+#! /bin/bash
+if [ ! -e $1 ]; then
+    echo $0: no input file $1 1>&2
+    exit 1
+fi
+cc="ccache gcc"
+if [ ! -z "$3" ]; then
+    cc=$3
+fi
+srcin=$1
+echo BasilysGcc $srcin 1>&2
+##***## CHANGE BELOW LINE APPROPRIATELY ACCORDING TO YOUR GCC BUILD DIRECTORY
+. /usr/src/Lang/basile-ggcc/_Obj/gcc/compile-basilys-defs
+# indent $srcin
+outn=$2
+if [ -z "$outn" ]; then
+    outn=$(basename $srcin .c).so
+fi
+rm $outn
+objn=$(basename $srcin .c).pic.o
+barn=$(basename $srcin .c)
+datf=$(tempfile -s .c -p bdat)
+md5src=$(md5sum $srcin)
+date "+const char basilys_compiled_timestamp[]=\"$barn %c\";" > $datf
+echo "const char basilys_md5[]=\"$md5src\";" >> $datf
+## ccache works only with a -c option
+$cc -time  -fPIC  -g3  $ALL_CFLAGS $ALL_CPPFLAGS $srcin -c -o $objn
+gcc -shared -fPIC $objn $datf -o $outn
+head -9 $datf
+rm -f $datf
+echo "Basilysgcc -shared -fPIC -fno-inline -g3 -Wextra -Wall $ALL_CFLAGS $ALL_CPPFLAGS $srcin -o $outn" 
+ls -l $outn* $objn*
+############################## END OF basilys-gcc
+
+However, you have to change the sourcing of /usr/src/Lang/basile-ggcc/_Obj/gcc/compile-basilys-defs
+into the sourcing of $YOURBUILDGCCDIR/gcc/compile-basilys-defs
+
+You might also compile *.bysl file with the contrib/cold-basilys.lisp
+using CLISP with a script coldbasilys similar to
+
+############################## CUT HERE file coldbasilys to be installed in your $PATH
+#! /usr/bin/clisp -C
+;; !#
+
+;; -*- lisp -*-
+
+(proclaim '(optimize (debug 0) (safety 1) (speed 3)))
+
+(let 
+( (argv 
+   EXT:*ARGS*
+   ))	
+     (format *error-output* "coldbasilys start ~s ~%" argv))
+
+
+(load "cold-basilys.lisp")
+
+(time (mapc (function handle-source-file) EXT:*ARGS*))
+
+#################################### end of coldbasilys
+
+I am sorry for all this temporary mess. As soon as warm-basilys.bysl
+is debugged, it should bootstrap itself in the following sense:
+
+  a *generated* warm-basilys.c exists somewhere; it is quite big (>300KLOC)
+
+  this generated file should be compiled (successfully) by the above
+  basilys-gcc script into a warm-basilys.so (to be put in a place to be defined)
+
+  this warm-basilys.so is dynamically loaded by cc1 thru 
+
+ gcc/cc1  -fbasilys -fbasilys-init=warm-basilys.so \
+          -fbasilys-command=compileseq -fbasilys-arg=warm-basilys.bysl \
+	  -frandom-seed=AbCdEfGhIj
+
+for debugging I usually add the  -fbasilys-debug -fdump-ipa-basilys flags which should not be needed
+
+You should also be able to generate this wam-basilys.c file with coldbasilys warm-basilys.bysl
+
+#### comments and questions to <basile@starynkevitch.net> 
diff --git a/gcc/melt/warm-basilys.bysl b/gcc/melt/warm-basilys.bysl
new file mode 100644
index 00000000000..b829bd811b9
--- /dev/null
+++ b/gcc/melt/warm-basilys.bysl
@@ -0,0 +1,8872 @@
+; -*- Lisp -*-
+;; file warm-basilys.bysl
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;    Copyright 2008 Free Software Foundation, Inc.
+;;    Contributed by Basile Starynkevitch <basile@starynkevitch.net>
+
+;;    This file is part of GCC.
+
+;;    GCC is free software; you can redistribute it and/or modify
+;;    it under the terms of the GNU General Public License as published by
+;;    the Free Software Foundation; either version 3, or (at your option)
+;;    any later version.
+
+;;    GCC is distributed in the hope that it will be useful,
+;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;    GNU General Public License for more details.
+
+;;    You should have received a copy of the GNU General Public License
+;;    along with GCC; see the file COPYING3.  If not see
+;;    <http://www.gnu.org/licenses/>.
+
+;;;;;;
+;;    This file is a bootstrapping compiler for the basilys lisp dialect
+;;    it should be able to compile itself (into a generated C file)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; root class
+(defclass class_root 
+ :predef CLASS_ROOT)
+
+;; class of everything with a property table
+(defclass class_proped 
+ :super class_root 
+ :fields (prop_table)
+ :predef CLASS_PROPED)
+
+
+;; arbitrary container as class
+(defclass class_container
+  :super class_root
+  :fields (container_value))
+
+;; class of named objects
+(defclass class_named 
+  :super class_proped 
+  :fields (named_name) 
+  :predef CLASS_NAMED)
+ 
+;; class of discriminants
+(defclass class_discr 
+  :super class_named 
+  :fields (disc_methodict 
+	   disc_sender 
+	   disc_super)
+  :predef CLASS_DISCR)
+ 
+;; class of classes
+(defclass class_class
+   :super class_discr
+   :fields (class_ancestors class_fields class_objnumdescr class_data)
+   :predef CLASS_CLASS)
+ 
+;; class of fields
+(defclass class_field
+  ;; the fields' objnum is its offset
+   :super class_named
+   :fields (fld_ownclass fld_typinfo)
+   :predef CLASS_FIELD)
+ 
+;; class of primitive
+(defclass class_primitive
+   :super class_named
+   :fields (prim_formals prim_type prim_expansion)
+   :predef CLASS_PRIMITIVE)
+ 
+;; class of located stuff
+(defclass class_located
+  :super class_proped
+  :fields (loca_location)
+  :predef CLASS_LOCATED)
+
+;; class of source expressions
+(defclass class_sexpr
+  :super class_located
+  :fields (sexp_contents		;list of contents
+	   )
+  :predef CLASS_SEXPR)
+
+;; class of message selectors
+(defclass class_selector
+  :super class_named
+  :fields (sel_signature sel_data)
+  :predef CLASS_SELECTOR)
+
+
+;; class of symbols
+(defclass class_symbol
+  :predef CLASS_SYMBOL
+  :super class_named
+  :fields (symb_data))
+
+;; class of generated (ie cloned) symbols - like lisp gensym
+(defclass class_clonedsymbol
+  :super class_symbol
+  :fields (csym_urank			;unique rank as a boxed integer
+	   ))
+
+;; class of keyword symbols
+(defclass class_keyword
+  :predef CLASS_KEYWORD
+  :super class_symbol
+  :fields ())
+
+;; class of C types keywords
+(defclass class_ctype
+  :super class_named
+  :fields (
+	   ctype_keyword ;the keyword associated to the ctype (e.g. :long)
+	   ctype_cname	 ;the name for C of the type (eg long)
+	   ctype_parchar ;the name of the basilys parameter char (eg BPAR_LONG)
+	   ctype_parstring ;the name of the basilys parameter string (eg BPARSTR_LONG)
+	   ctype_argfield ;the name of the basilys argument union field (eg bp_long)
+	   ctype_resfield ;the name of the basilys result union field (eg bp_longptr)
+	   )
+  )
+
+;; class of tokenizers
+(defclass class_tokenizer
+  :super class_named
+  :fields (tok_symboldict 		; stringmap for symbols
+	   tok_keywdict 			;stringmap for keywords
+	   tok_addsymbol 		;closure to add a symbol of given name
+	   tok_addkeyw		;closure to add a keyword of given name
+	   tok_internsymbol		;closure to intern a symbol
+	   tok_internkeyw		;closure to intern a keyword
+	   )
+  :predef CLASS_TOKENIZER)
+
+;; class of command dispatchers
+(defclass class_command_dispatcher
+  :super class_named
+  :fields (cmd_fundict			;stringmap for closures
+	   )
+  :predef CLASS_COMMAND_DISPATCHER)
+
+;; primitive for converting a string constant into a string value
+(defprimitive stringconst2val (discr :cstring strc) :value
+  " basilysgc_new_string((" discr "), (" strc "))")
+
+
+;; primitive for testing if an object is a (sub) instance of a class
+(defprimitive is_a (obj cla) :long
+  " basilys_is_instance_of((" obj "), (" cla "))")
+  
+;; primitive for testing objectness
+(defprimitive is_object (obj) :long
+  " (basilys_magic_discr(" obj ") == OBMAG_OBJECT)")
+  
+
+;; primitive to return the last predefined index
+(defprimitive last_globpredef_index () :long
+  "BGLOB__LASTGLOB")
+
+;; primitive to safely return a global predef by its index
+(defprimitive get_globpredef (:long ix) :value
+  "(basilys_globpredef((" ix ")))")
+
+;; primitive to get the discriminant of a value
+(defprimitive discrim (v) :value
+  "(basilys_discr((" v ")))")
+
+;; primitive to get the integer inside a boxed or mixed integer or objnum
+(defprimitive get_int (v) :long
+  "(basilys_get_int((" v ")))")
+;; primitive to put the integer inside a boxed or mixed integer or objnum
+(defprimitive put_int (v :long i) :void
+  "basilys_put_int((" v "), (" i "))")
+
+;; primitive to get the hashcode of an object (or 0)
+(defprimitive obj_hash(v) :long
+  "(basilys_obj_hash((" v ")))")
+;; primitive to get the length of an object (or 0)
+(defprimitive obj_len(v) :long
+  "(basilys_obj_len((" v ")))")
+;; primitive to get the number of an object (or 0)
+(defprimitive obj_num(v) :long
+  "(basilys_obj_num((" v ")))")
+;; primitive to compue a nonzero hash
+(defprimitive nonzero_hash () :long
+  "(basilys_nonzerohash())")
+
+;; primitive for identity and non-identity test
+(defprimitive == (a b) :long "((" a ") == (" b "))")
+(defprimitive != (a b) :long "((" a ") != (" b "))")
+
+;; primitive always returning nil
+(defprimitive the_null () :value "(NULL)")
+
+;;; the call counter
+(defprimitive the_callcount () :long "callcount")
+
+;; primitive to get or create a symbol from a string value
+(defprimitive get_symbolstr (strv) :value
+  "basilysgc_named_symbol( basilys_string_str(" strv "), BASILYS_GET)")
+(defprimitive create_symbolstr (strv) :value
+  "basilysgc_named_symbol( basilys_string_str(" strv "), BASILYS_CREATE)")
+
+;; primitive to get or create a keyword from a string value
+(defprimitive get_keywordstr (strv) :value
+  "basilysgc_named_keyword( basilys_string_str(" strv "), BASILYS_GET)")
+(defprimitive create_keywordstr (strv) :value
+  "basilysgc_named_keyword( basilys_string_str(" strv "), BASILYS_CREATE)")
+
+;; runtime assertion with message
+(defprimitive assert_msg (:cstring msg :long cond) :void
+  "basilys_assertmsg(" msg ", ( " cond "))")
+;; check explicitly the call stack  
+(defprimitive checkcallstack_msg (:cstring msg) :void
+ "basilys_check_call_frames(BASILYS_ANYWHERE, (" msg "))")
+;; for brezakpoint
+(defprimitive cbreak_msg (:cstring msg) :void
+ "basilys_cbreak(" msg ")")
+
+;;; less, lessorequal, greater, greaterorequal, equal, different number 
+(defprimitive <i (:long a b) :long "((" a ") < (" b "))")
+(defprimitive <=i (:long a b) :long "((" a ") <= (" b "))")
+(defprimitive ==i (:long a b) :long "((" a ") == (" b "))")
+(defprimitive >i (:long a b) :long "((" a ") > (" b "))")
+(defprimitive >=i (:long a b) :long "((" a ") >= (" b "))")
+(defprimitive !=i (:long a b) :long "((" a ") != (" b "))")
+;;; integer arithmetic
+(defprimitive +i (:long a b) :long "((" a ") + (" b "))")
+(defprimitive -i (:long a b) :long "((" a ") - (" b "))")
+(defprimitive *i (:long a b) :long "((" a ") * (" b "))")
+(defprimitive andi (:long a b) :long "((" a ") & (" b "))")
+(defprimitive ori (:long a b) :long "((" a ") | (" b "))")
+(defprimitive xori (:long a b) :long "((" a ") ^ (" b "))")
+(defprimitive negi (:long i) :long "(-(" i "))")
+(defprimitive noti (:long i) :long "(~(" i "))")
+
+(defprimitive /i (:long a b) :long "(basilys_idiv(" a "), (" b "))")
+(defprimitive %i (:long a b) :long "(basilys_imod(" a "), (" b "))")
+(defprimitive /iraw (:long a b)  :long "((" a ") / (" b "))")
+(defprimitive %iraw (:long a b)  :long "((" a ") % (" b "))")
+;; boolean not
+(defprimitive not (:long i) :long "(!(" i "))")
+;;; nullity test (for values)
+(defprimitive null (v) :long "((" v ") == NULL)")
+(defprimitive notnull (v) :long "((" v ") != NULL)")
+;;; zero test (for numbers)
+(defprimitive zerop (:long i) :long "((" i ") == OL)")
+;; primitive for testing if debug
+(defprimitive need_dbg (:long depth) :long
+  "(dump_file && (" depth ")>=0 && (" depth ") <= BASILYSDBG_MAXDEPTH)")
+
+(defprimitive need_dbglim (:long depth limit) :long
+  "(dump_file && (" depth ")>=0 && (" depth ") < (" limit "))")
+
+(defprimitive outstrcont_dbg (:cstring s) :void
+  "basilys_puts(dump_file,(" s "))")
+(defprimitive outnum_dbg (:cstring pref :long l :cstring suf) :void
+  "basilys_putnum(dump_file,(" pref "), (" l "), (" suf "))")
+(defprimitive outstr_dbg (str) :void
+  "basilys_putstr(dump_file,(" str "))")
+(defprimitive outstrbuf_dbg (sbuf) :void
+  "basilys_putstrbuf(dump_file,(" sbuf "))")
+(defprimitive outnewline_dbg () :void
+  "basilys_newlineflush(dump_file)")
+
+(defprimitive output_cfile_decl_impl (uninam declbuf implbuf) :void
+  "basilys_output_cfile_decl_impl((" uninam "), (" declbuf "), (" implbuf "))")
+
+(defprimitive message_dbg (:cstring msg) :void
+  "debugeputs((" msg "))")
+(defprimitive messagenum_dbg (:cstring msg :long i) :void
+  "debugnum((" msg "), (" i "))")
+(defprimitive messageval_dbg (:cstring msg :value val) :void
+  "debugvalue((" msg "), ((void*)(" val ")))")
+(defprimitive longbacktrace_dbg (:cstring msg :long maxdepth) :void
+  "debugbacktrace((" msg "), (int)(" maxdepth "))")
+(defprimitive shortbacktrace_dbg (:cstring msg :long maxdepth) :void
+  "basilys_dbgshortbacktrace((" msg "), (" maxdepth "))")
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;; STRBUF primitives
+;; primitive to make a strbuf
+(defprimitive make_strbuf (discr) :value
+  "basilysgc_new_strbuf((" discr "), (char*)0)")
+(defprimitive strbuf_usedlength (sbuf) :long
+  "basilys_strbuf_usedlength((" sbuf "))")
+
+(defprimitive is_strbuf (v) :long
+  "(basilys_magic_discr((" v ")) == OBMAG_STRBUF)")
+;; primitive to add a string const into a strbuf
+(defprimitive add2sbuf_strconst (sbuf :cstring str) :void 
+  "basilysgc_add_strbuf((" sbuf "), (" str "))")
+;; primitive to add a string value into a strbuf
+(defprimitive add2sbuf_string (sbuf str) :void 
+  "basilysgc_add_strbuf((" sbuf "), basilys_string_str(" str "))")
+
+;; primitive to add an indentation or space into a strbuf
+(defprimitive add2sbuf_indent (sbuf :long depth) :void
+  "basilysgc_strbuf_add_indent((" sbuf "), (" depth "), 72)")
+
+
+;; primitive to add an indented newline into a strbuf
+(defprimitive add2sbuf_indentnl (sbuf :long depth) :void
+  "basilysgc_strbuf_add_indent((" sbuf "), (" depth "), 0)")
+
+
+;; primitive to add a strbuf into a strbuf
+(defprimitive add2sbuf_sbuf (sbuf asbuf) :void 
+  "basilysgc_add_strbuf((" sbuf "), basilys_strbuf_str(" asbuf "))")
+
+;; primitive to add a string value, C encoded, into a strbuf
+(defprimitive add2sbuf_cencstring (sbuf str) :void 
+  "basilysgc_add_strbuf_cstr((" sbuf "), basilys_string_str(" str "))")
+
+;; primitive to add a strbuf, C encoded, into a strbuf
+(defprimitive add2sbuf_cencstrbuf (sbuf asbuf) :void 
+  "basilysgc_add_strbuf_cstr((" sbuf "), basilys_strbuf_str(" asbuf "))")
+
+;; primitive to add a string value, Ccomment encoded, into a strbuf
+(defprimitive add2sbuf_ccomstring (sbuf str) :void 
+  "basilysgc_add_strbuf_ccomment((" sbuf "), basilys_string_str(" str "))")
+
+;; primitive to add a strbuf, C encoded, into a strbuf
+(defprimitive add2sbuf_ccomstrbuf (sbuf asbuf) :void 
+  "basilysgc_add_strbuf_ccomment((" sbuf "), basilys_strbuf_str(" asbuf "))")
+
+
+;; primitive to add into a strbuf a string as C ident (nonalphanum
+;; replaced by _)
+(defprimitive add2sbuf_cident (sbuf str) :void
+  "basilysgc_add_strbuf_cident((" sbuf "), basilys_string_str(" str "))")
+
+;; primitive to add into a strbuf the prefix of a string as C ident (nonalphanum
+;; replaced by _) limited by a small length 
+(defprimitive add2sbuf_cidentprefix  (sbuf str :long preflen) :void
+  "basilysgc_add_strbuf_cidentprefix((" sbuf "), basilys_string_str(" str "), (" preflen "))")
+
+;; primitive to add a long in decimal into a strbuf
+(defprimitive add2sbuf_longdec (sbuf :long num) :void
+  "basilysgc_add_strbuf_dec((" sbuf "), (" num "))")
+
+;; primitive to add a long in hex into a strbuf
+(defprimitive add2sbuf_longhex (sbuf :long num) :void
+  "basilysgc_add_strbuf_hex((" sbuf "), (" num "))")
+
+;; primitive to add a routine descr into a strbuf
+(defprimitive add2sbuf_routinedescr (sbuf rout) :void
+  "basilysgc_add_strbuf((" sbuf "), basilys_routine_descrstr(" rout "))")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; STRING primitives
+;; primitive for testing if a value is a string
+(defprimitive is_string (str) :long
+  " (basilys_magic_discr(" str ") == OBMAG_STRING)")
+;; string equal
+(defprimitive ==s (s1 s2) :long
+  "basilys_string_same((" s1 "), (" s2 "))")
+;;; make a string
+(defprimitive make_string (dis str) :value
+  "(basilysgc_new_stringdup((" dis "), basilys_string_str((" str "))))")
+(defprimitive make_stringconst (dis :cstring cstr) :value
+  "(basilysgc_new_stringdup((" dis "), (" cstr ")))")
+
+(defprimitive string_length (str) :long
+  "basilys_string_length((" str "))")
+;;; convert a strbuf into a string
+(defprimitive strbuf2string (dis sbuf) :value
+  "(basilysgc_new_stringdup((" dis "), basilys_strbuf_str((" sbuf "))))")
+;;; compute the naked basename
+(defprimitive make_string_nakedbasename (dis str) :value
+ "(basilysgc_new_string_nakedbasename((" dis "), basilys_string_str((" str "))))")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; OBJECT primitives
+;; primitive to get an object length
+(defprimitive object_length (ob) :long 
+  "((long)basilys_object_length((" ob ")))")
+;; primitive to get the nth field of an object
+(defprimitive object_nth_field (ob :long n) :value
+  "(basilys_field_object((" ob "), (" n ")))")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;; MULTIPLEs primitives
+;;;; test
+(defprimitive is_multiple (mul) :long
+ "(basilys_magic_discr((" mul  ")) == OBMAG_MULTIPLE)")
+(defprimitive is_multiple_or_null (mul) :long
+ "((" mul ") == NULL || (basilys_magic_discr((" mul  ")) == OBMAG_MULTIPLE))")
+;;; make
+(defprimitive make_multiple (discr :long ln) :value
+  "(basilysgc_new_multiple((" discr "), (" ln ")))")
+(defprimitive make_tuple1 (discr v1) :value
+  "(basilysgc_new_mult1((" discr "),(" v1 ")))")
+(defprimitive make_tuple2 (discr v1 v2) :value
+  "(basilysgc_new_mult2((" discr "),(" v1 "), (" v2 ")))")
+(defprimitive make_tuple3 (discr v1 v2 v3) :value
+  "(basilysgc_new_mult3((" discr "),(" v1 "), (" v2  "), (" v3 ")))")
+(defprimitive make_tuple4 (discr v1 v2 v3 v4) :value
+  "(basilysgc_new_mult4((" discr "),(" v1 "), (" v2  "), (" v3  "), (" v4 ")))")
+(defprimitive make_tuple5 (discr v1 v2 v3 v4 v5) :value
+  "(basilysgc_new_mult5((" discr "),(" v1 "), (" v2  "), (" v3  "), (" v4  "), (" v5 ")))")
+;; primitive to get the nth  in a multiple
+(defprimitive multiple_nth (mul :long n) :value
+    "(basilys_multiple_nth((" mul "), (" n ")))")
+;; primitive to get the length of a multiple
+(defprimitive multiple_length (v) :long
+  "(basilys_multiple_length((" v ")))")
+;; be careful to avoid circularities
+(defprimitive multiple_put_nth (mul :long n :value v) :void
+  " basilysgc_multiple_put_nth((" mul "), (" n "), (" v "))")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;; MAPOBJECTs primitives
+;;;; test
+(defprimitive is_mapobject (map) :long
+ "(basilys_magic_discr((" map  ")) == OBMAG_MAPOBJECTS)")
+;; primitive to get the allocated size of a mapobject
+(defprimitive mapobject_size (map) :long
+  "(basilys_size_mapobjects(" map "))")
+;; primitive to get the attribute count of a mapobject
+(defprimitive mapobject_count (map) :long
+  "(basilys_count_mapobjects(" map "))")
+;; primitive to get the nth attribute of a mapobject
+(defprimitive mapobject_nth_attr (map :long n) :value
+  "(basilys_nthattr_mapobjects((" map "), (int)(" n ")))")
+;; primitive to get the nth value of a mapobject
+(defprimitive mapobject_nth_val (map :long n) :value
+  "(basilys_nthval_mapobjects((" map "), (int)(" n ")))")
+;; primitive to get the value of an attribute in a mapobject
+(defprimitive mapobject_get (map attr) :value
+  "(basilys_get_mapobjects((" map "), (" attr ")))")
+;; primitive for making a new map of objects
+(defprimitive make_mapobject (discr :long len) :value
+  " (basilysgc_new_mapobjects( (void*) (" discr "), (" len ")))")
+;; primitive for putting into a map of objects
+(defprimitive mapobject_put (map key val) :void
+ " basilysgc_put_mapobjects( (void*) (" map "), (" key "), (" val "))")
+;; primivite for removing from a map of objects
+(defprimitive mapobject_remove (map key) :void
+  " basilysgc_remove_mapobjects( (void*) (" map "), (" key "))")
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;; MAPSTRINGs primitive
+;; test
+(defprimitive is_mapstring (map) :long
+"(basilys_magic_discr((" map ")) == OBMAG_MAPSTRINGS)")
+;; primitive to get the allocated size of a mapstring
+(defprimitive mapstring_size (map) :long 
+  "(basilys_size_mapstrings(" map "))")
+;; primitive to get the attribute count of a mapstring
+(defprimitive mapstring_count (map) :long
+  "(basilys_count_mapstrings(" map "))")
+;; get an entry in a mapstring from a C string
+(defprimitive mapstring_rawget (map :cstring cstr) :value
+  "(basilys_get_mapstrings((" map "), (" cstr ")))")
+;; primitive for making a new map of strings
+(defprimitive make_mapstring (discr :long len) :value
+  " (basilysgc_new_mapstrings( (void*) (" discr "), (" len ")))")
+;; primitive for putting into a map of strings
+(defprimitive mapstring_rawput (map :cstring key :value val) :void
+ " basilysgc_put_mapstrings( (void*) (" map "), (" key "), (" val "))")
+(defprimitive mapstring_putstr (map keystr val) :void
+  " basilysgc_put_mapstrings((void*) (" map "), basilys_string_str(" keystr "), (" val "))")
+(defprimitive mapstring_getstr (map keystr) :value
+  "(basilys_get_mapstrings((" map "), basilys_string_str(" keystr ")))")
+;; primivite for removing from a map of strings
+(defprimitive mapstring_rawremove (map :cstring key) :void
+  " basilysgc_remove_mapstrings( (void*) (" map "), (" key "))")
+
+;; primitive to make the nth stringattr of a mapobject
+(defprimitive mapstring_nth_attrstr (map sdicr :long n) :value
+  "(basilysgc_new_stringdup((" sdicr "), basilys_nthattrraw_mapstrings((" map "), (int)(" n "))))")
+;; primitive to get the nth value of a mapobject
+(defprimitive mapstring_nth_val (map :long n) :value
+  "(basilys_nthval_mapstrings((" map "), (int)(" n ")))")
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;; ROUTINEs primitives
+;; test
+(defprimitive is_routine (rou) :long
+"(basils_magic_discr((" rou ")) == OBMAG_ROUTINE)")
+;;; descriptive string of a routine
+(defprimitive routine_descr (rou) :value
+  "(basilysgc_new_stringdup(basilys_routine_descrstr((" rou "))))")
+;;; size of a routine
+(defprimitive routine_size  (rou) :long
+  "(basilys_routine_size((" rou ")))")
+;;; nth comp in routine
+(defprimitive routine_nth (rou :long ix) :value
+"(basilys_routine_nth((" rou "), (int) (" ix ")))")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;; CLOSUREs primitives
+;; test
+(defprimitive is_closure (clo) :long
+  " (basilys_magic_discr((" clo ")) == OBMAG_CLOSURE)")
+(defprimitive closure_size (clo) :long
+  " (basilys_closure_size((" clo ")))")
+(defprimitive closure_routine (clo) :value
+ " (basilys_closure_routine((" clo ")))")
+(defprimitive closure_nth (clo :long ix) :value
+  "(basilys_closure_nth((" clo "), (int)(" ix ")))")
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;; boxed INTEGERs primitives
+;; test
+(defprimitive is_integerbox (ib) :long
+  "(basilys_magic_discr((" ib ")) == OBMAG_INT)")
+;; to get the boxed integer use get_int
+;; make
+(defprimitive make_integerbox (discr :long n) :value
+  "(basilysgc_new_int((" discr "), (" n ")))")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; BOX primitives (boxed values)
+;; test
+(defprimitive is_box (bx) :long
+  "(basilys_magic_discr((" bx ")) == OBMAG_BOX)")
+;; safe fetch content
+(defprimitive box_content (box) :value
+  "basilys_box_content((" box "))")
+;; put into a box
+(defprimitive box_put (box val) :void
+  "basilysgc_box_put((" box "), (" val "))")
+;; make a box
+(defprimitive make_box (discr valb) :value
+  "basilysgc_new_box((" discr "), (" valb "))")
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; LIST primitives
+;; test
+(defprimitive is_list (li) :long
+  "(basilys_magic_discr((" li ")) == OBMAG_LIST)")
+(defprimitive is_list_or_null (li) :long
+  "((" li ") == NULL || (basilys_magic_discr((" li ")) == OBMAG_LIST))")
+;; first pair of list
+(defprimitive list_first (li) :value
+  "(basilys_list_first((" li ")))")
+;; last pair of list
+(defprimitive list_last (li) :value
+"(basilys_list_last((" li ")))")
+;; length of list
+(defprimitive list_length (li) :long
+"(basilys_list_length((" li ")))")
+;; append into list
+(defprimitive list_append (li el) :void
+"basilysgc_append_list((" li "), (" el "))")
+;; prepend into list
+(defprimitive list_prepend (li el) :void
+"basilysgc_prepend_list((" li "), (" el "))")
+;; pop first from list
+(defprimitive list_popfirst (li) :value
+  "(basilysgc_popfirst_list((" li ")))")
+;; make list
+(defprimitive make_list (discr) :value
+"(basilysgc_new_list((" discr ")))")
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; PAIR primitives
+;; test
+(defprimitive is_pair (pa) :long
+  "(basilys_magic_discr((" pa ")) == OBMAG_PAIR)")
+;; head
+(defprimitive pair_head (pa) :value
+  "(basilys_pair_head((" pa ")))")
+;; tail
+(defprimitive pair_tail (pa) :value
+  "(basilys_pair_tail((" pa ")))")
+;; change the head of a pair
+(defprimitive pair_set_head (pa hd) :void
+  "basilysgc_pair_set_head((" pa "), (" hd "))")
+;; length of a pair list
+(defprimitive pair_listlength (pa) :long
+  "(basilys_pair_listlength((" pa ")))")
+;; make
+(defprimitive pair_make (discr hd tl) :value
+  "(basilysgc_new_pair((" discr "), (" hd "), (" tl ")))")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;; MIXINT primitives (use get_int to get the integer)
+;; test
+(defprimitive is_mixint (mi) :long
+  "(basilys_magic_discr((" mi ")) == OBMAG_MIXINT)")
+;; get the value
+(defprimitive mixint_val (mi) :value
+  "(basilys_val_mixint((" mi ")))")
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; READ FILE primitive
+(defprimitive read_file (filnam) :value
+  "(basilysgc_read_file (basilys_string_str((" filnam "))))")
+
+;; to signal an error in a basilys source with some additional string value
+(defprimitive error_strv (loc :cstring msg :value strv) :void
+  "error(\"BASILYS ERROR: file %s line %d : %s - %s\","
+  " basilys_string_str(basilys_val_mixint(" loc ")), "
+  " (int) basilys_num_mixint(" loc "), ("
+  msg
+  "), basilys_string_str((" strv ")))"
+  )
+;; signal a plain error in a basilys source
+(defprimitive error_plain (loc :cstring msg) :void
+  "error(\"BASILYS ERROR: file %s line %d :: %s \","
+  " basilys_string_str(basilys_val_mixint(" loc ")), "
+  " (int) basilys_num_mixint(" loc "), ("
+  msg "))"
+  )
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; the discriminant for name strings
+(definstance discr_namestring class_discr
+ :predef DISCR_NAMESTRING
+ :obj_num OBMAG_STRING
+ :named_name (stringconst2val discr_namestring "DISCR_NAMESTRING")
+;;; :disc_super discr_string   ;; forward reference not allowed
+)
+
+;;; the discriminant for strings
+(definstance discr_string class_discr
+ :predef DISCR_STRING
+ :obj_num OBMAG_STRING
+ :named_name (stringconst2val discr_namestring "DISCR_STRING"))
+
+(unsafe_put_fields discr_namestring :disc_super discr_string)
+
+;;; the discriminant for verbatim strings (used for defprimitive)
+(definstance discr_verbatimstring class_discr
+ :obj_num OBMAG_STRING
+ :predef DISCR_VERBATIMSTRING
+ :named_name (stringconst2val discr_namestring "DISCR_VERBATIMSTRING")
+ :disc_super discr_string
+)
+
+;;; the discriminant for any reciever (used for sending to everything)
+(definstance discr_anyrecv class_discr
+  :named_name (stringconst2val discr_namestring "DISCR_ANYRECV")
+)
+
+(unsafe_put_fields discr_string :disc_super discr_anyrecv)
+
+;;; the discriminant for null reciever (used for sending to nil)
+(definstance discr_nullrecv class_discr
+  :predef DISCR_NULLRECV
+  :disc_super discr_anyrecv
+  :named_name (stringconst2val discr_namestring "DISCR_NULLRECV"))
+
+;;; the discriminant for strbuf
+(definstance discr_strbuf class_discr
+ :obj_num OBMAG_STRBUF  
+ :disc_super discr_anyrecv
+ :named_name (stringconst2val discr_namestring "DISCR_STRBUF"))
+
+;;; the discriminant for integers
+(definstance discr_integer class_discr
+ :predef DISCR_INTEGER
+ :obj_num OBMAG_INT 
+ :disc_super discr_anyrecv
+ :named_name (stringconst2val discr_namestring "DISCR_INTEGER"))
+
+;;; the discriminant for lists
+(definstance discr_list class_discr
+  :predef DISCR_LIST
+  :obj_num OBMAG_LIST 
+  :disc_super discr_anyrecv
+  :named_name (stringconst2val discr_namestring "DISCR_LIST"))
+
+;;; the discriminant for pairs
+(definstance discr_pair class_discr
+  :predef DISCR_PAIR
+  :obj_num OBMAG_PAIR 
+  :disc_super discr_anyrecv
+  :named_name (stringconst2val discr_namestring "DISCR_PAIR"))
+
+;;; the discriminant for multiples
+(definstance discr_multiple class_discr
+  :predef DISCR_MULTIPLE
+  :obj_num OBMAG_MULTIPLE
+  :disc_super discr_anyrecv
+  :named_name (stringconst2val discr_namestring "DISCR_MULTIPLE"))
+
+;;; the discriminant for sequence of fields
+(definstance discr_seqfield class_discr
+  :predef DISCR_SEQFIELD
+  :obj_num OBMAG_MULTIPLE
+  :named_name (stringconst2val discr_namestring "DISCR_SEQFIELD")
+  :disc_super discr_multiple
+)
+
+;;; the discriminant for boxes
+(definstance discr_box class_discr
+  :predef DISCR_BOX
+  :obj_num OBMAG_BOX
+  :disc_super discr_anyrecv
+  :named_name (stringconst2val discr_namestring "DISCR_BOX"))
+
+;;; the discriminant for maps of objects
+(definstance discr_mapobjects class_discr
+  :predef DISCR_MAPOBJECTS
+  :obj_num OBMAG_MAPOBJECTS
+  :disc_super discr_anyrecv
+  :named_name (stringconst2val discr_namestring "DISCR_MAPOBJECTS"))
+
+;;; the discriminant for maps of strings
+(definstance discr_mapstrings class_discr
+  :predef DISCR_MAPSTRINGS
+  :obj_num OBMAG_MAPSTRINGS
+  :disc_super discr_anyrecv
+  :named_name (stringconst2val discr_namestring "DISCR_MAPSTRINGS"))
+
+;;; the discriminant for sequence of classes 
+(definstance discr_seqclass class_discr
+  :predef DISCR_SEQCLASS
+  :obj_num OBMAG_MULTIPLE
+  :named_name (stringconst2val discr_namestring "DISCR_SEQCLASS")
+  :disc_super discr_multiple
+)
+
+
+;;; the discriminant for method dictionnary maps
+(definstance discr_methodmap class_discr
+  :predef DISCR_METHODMAP
+  :obj_num OBMAG_MAPOBJECTS
+  :disc_super discr_mapobjects
+  :named_name (stringconst2val discr_namestring "DISCR_METHODMAP"))
+
+;;; the discriminant for charcode integers
+(definstance discr_charinteger class_discr
+ :predef DISCR_CHARINTEGER
+ :obj_num OBMAG_INT
+ :named_name (stringconst2val discr_namestring "DISCR_CHARINTEGER")
+ :disc_super discr_integer
+)
+
+
+;;; the discriminant for mixedintegers
+(definstance discr_mixedint class_discr
+ :predef DISCR_MIXEDINT
+ :obj_num OBMAG_MIXINT
+ :disc_super discr_anyrecv
+ :named_name (stringconst2val discr_namestring "DISCR_MIXEDINT"))
+
+
+;;; the discriminant for closures
+(definstance discr_closure class_discr
+ :predef DISCR_CLOSURE
+ :obj_num OBMAG_CLOSURE
+ :disc_super discr_anyrecv
+ :named_name (stringconst2val discr_namestring "DISCR_CLOSURE"))
+
+;;; the discriminant for routines
+(definstance discr_routine class_discr
+ :predef DISCR_ROUTINE
+ :obj_num OBMAG_ROUTINE
+ :disc_super discr_anyrecv
+ :named_name (stringconst2val discr_namestring "DISCR_ROUTINE"))
+
+(defun install_ctype (ctyp)
+  (assert_msg "check ctyp" (is_a ctyp class_ctype)) 
+  (debug_msg "install_ctype" ctyp (the_callcount))
+  (let ( (ckw (unsafe_get_field :ctype_keyword ctyp)) )
+    (assert_msg "check ckw" (is_a ckw class_keyword))
+    (unsafe_put_fields ckw :symb_data ctyp)
+))
+
+
+;;; every ctype should be predefined. normexp_defprimitive requires this
+;;; while predef are somehow costly, we don't have that much many ctype-s
+;;; and each of them nearly requires some code in basilys.h
+;;; which should be enhanced for any new ctype
+;; the C type for values
+(definstance ctype_value class_ctype
+  :predef CTYPE_VALUE
+  :named_name  (stringconst2val discr_namestring "CTYPE_VALUE")
+  :ctype_keyword (quote :value)
+  :ctype_cname  (stringconst2val discr_namestring "basilys_ptr_t")
+  :ctype_parchar (stringconst2val discr_namestring "BPAR_PTR")
+  :ctype_parstring (stringconst2val discr_namestring "BPARSTR_PTR")
+  ;; value have to be passed specially, we need to pass the address of the pointer
+  :ctype_argfield (stringconst2val discr_namestring "bp_aptr")
+  :ctype_resfield (stringconst2val discr_namestring "bp_aptr")
+  )
+(install_ctype ctype_value)
+
+;; the C type for long
+(definstance ctype_long class_ctype
+  :predef CTYPE_LONG
+  :named_name  (stringconst2val discr_namestring "CTYPE_LONG")
+  :ctype_keyword (quote :long)
+  :ctype_cname  (stringconst2val discr_namestring "long")
+  :ctype_parchar (stringconst2val discr_namestring "BPAR_LONG")
+  :ctype_parstring (stringconst2val discr_namestring "BPARSTR_LONG")
+  :ctype_argfield (stringconst2val discr_namestring "bp_long")
+  :ctype_resfield (stringconst2val discr_namestring "bp_longptr")
+  )
+(install_ctype ctype_long)
+
+;; the C type for gcc trees
+(definstance ctype_tree class_ctype
+  :predef CTYPE_TREE
+  :named_name  (stringconst2val discr_namestring "CTYPE_TREE")
+  :ctype_keyword ':tree
+  :ctype_cname  (stringconst2val discr_namestring "tree")
+  :ctype_parchar (stringconst2val discr_namestring "BPAR_TREE")
+  :ctype_parstring (stringconst2val discr_namestring "BPARSTR_TREE")
+  :ctype_argfield (stringconst2val discr_namestring "bp_tree")
+  :ctype_resfield (stringconst2val discr_namestring "bp_treeptr")
+  )
+(install_ctype ctype_tree)
+
+;; the C type for void
+(definstance ctype_void class_ctype
+  :predef CTYPE_VOID
+  :named_name  (stringconst2val discr_namestring "CTYPE_VOID")
+  :ctype_keyword ':void
+  :ctype_cname  (stringconst2val discr_namestring "void")
+  ;; void is never passed as argument or as extra result
+  )
+(install_ctype ctype_void)
+
+;; the C type for constant C strings
+(definstance ctype_cstring class_ctype
+  :predef CTYPE_CSTRING
+  :named_name  (stringconst2val discr_namestring "CTYPE_CSTRING")
+  :ctype_keyword ':cstring
+  :ctype_cname  (stringconst2val discr_namestring "char*")
+  ;; constant strings are not passed as argument, this might change in the future
+  )
+(install_ctype ctype_cstring)
+
+
+;; function to box a value
+
+(defun boxval (v) 
+  (make_box discr_box v))
+
+;; function to add a new symbol
+(defun add_new_symbol_token (tokz str)
+  (let ( (sy (make_instance class_symbol :named_name str)) 
+	 (sydict (unsafe_get_field :tok_symboldict tokz))
+	 )
+    (mapstring_putstr sydict str sy)
+    sy))
+    
+;; function to add a new keyword
+(defun add_new_keyword_token (tokz str)
+  (let ( (kw (make_instance class_keyword :named_name str)) 
+	 (kwdict (unsafe_get_field :tok_keywdict tokz))
+	 )
+    (mapstring_putstr kwdict str kw)
+    kw))
+    
+;; function to intern a symbol (or return the previous one)
+(defun intern_symbol (tokz symb)
+  (assert_msg "check tokz" (is_a tokz class_tokenizer))
+  (assert_msg "check sym" (is_a symb class_symbol))
+  (let ( (syname (unsafe_get_field :named_name symb)) 
+	 (sydict (unsafe_get_field :tok_symboldict tokz))
+	 (oldsy (mapstring_getstr sydict syname)) )
+    (or oldsy (progn 
+		(mapstring_putstr sydict syname symb) 
+;		(messageval_dbg "warm interning symbol" symb)
+		symb))
+))
+
+;; function to intern a keyword (or return the previous one)
+(defun intern_keyword (tokz keyw)
+  (assert_msg "check tokz" (is_a tokz class_tokenizer))
+  (assert_msg "check keyw" (is_a keyw class_keyword))
+  (let ( (kwname (unsafe_get_field :named_name keyw)) 
+	 (kwdict (unsafe_get_field :tok_keywdict tokz))
+	 (oldkw (mapstring_getstr kwdict kwname)) )
+    (or oldkw (progn (mapstring_putstr kwdict kwname keyw) keyw))
+))
+
+;;; container of a mapstring for cloning symbol, maping symbol names to boxed integer
+(definstance container_clonemapstring class_container
+  :container_value (make_mapstring discr_mapstrings 200)
+)
+
+(defun clone_symbol (symb)
+  (let ( (mapstr (unsafe_get_field :container_value container_clonemapstring)) 
+	 (synam (cond
+		 ( (is_a symb class_named) 
+		   (unsafe_get_field :named_name symb))
+		 ( (is_string symb) 
+		   symb)
+		 (:else 
+		  (debug_msg "clone_symbol bad symb" symb (the_callcount))
+		  (assert_msg "invalid symb in clone_symbol" ())
+		  (return))))
+	 (boxi (mapstring_getstr mapstr synam)) )
+    (or (is_integerbox boxi)
+	(progn 
+	  (setq boxi (make_integerbox discr_integer 0))
+	  (mapstring_putstr mapstr synam boxi)))
+    (let ( (:long i (get_int boxi)) )
+      (setq i (+i i 1))
+      (put_int boxi i)
+      (make_instance class_clonedsymbol
+		     :named_name synam
+		     :csym_urank (make_integerbox discr_integer i)))))
+
+;; the tokenizer
+(definstance tokenizer class_tokenizer
+  :predef TOKENIZER
+  :named_name  (stringconst2val discr_namestring "TOKENIZER")
+  :tok_symboldict (make_mapstring discr_mapstrings 200)
+  :tok_keywdict (make_mapstring discr_mapstrings 100)
+  :tok_addsymbol add_new_symbol_token
+  :tok_addkeyw  add_new_keyword_token
+  :tok_internsymbol intern_symbol
+  :tok_internkeyw intern_keyword
+  )
+
+;;; iterate over a map of object - if the called f returns nil the
+;;; iteration is stopped and returns the "failing" attr
+(defun mapobject_iterate (map f)
+  (if (is_mapobject map)
+      (if (is_closure f)
+	  (let ( (:long ix 0) )
+	    (forever maploop
+		     (if (>=i ix (mapobject_size map)) (exit maploop))
+		     (let ( (curat (mapobject_nth_attr map ix))
+			    (curval (mapobject_nth_val map ix)) )
+		       (if curat 
+			   (if (null (f curat curval))
+			       (exit maploop curat))
+			 ))
+		     (setq ix (+i ix 1))
+		     )))))
+
+;;; iterate over a map of strings - if the called f returns nil the
+;;; iteration is stopped
+(defun mapstring_iterate (map f)
+  (if (is_mapstring map)
+      (if (is_closure f)
+	  (let ( (:long ix 0) )
+	    (forever maploop
+		     (if (>=i ix (mapstring_size map)) (exit maploop))
+		     (let ( (curat (mapstring_nth_attrstr map discr_string ix))
+			    (curval (mapstring_nth_val map ix)) )
+		       (if curat 
+			   (if (null (f curat curval))
+			       (exit maploop curat)
+			     )))
+		     (setq ix (+i ix 1))
+		     )))))
+
+;;; iterate in a dictionnary ie on the value in a map of strings - if
+;;; the called f returns nil the iteration is stooped
+(defun mapstringval_iterate (map f)
+  (if (is_mapstring map)
+      (if (is_closure f)
+	  (let ( (:long ix 0) )
+	    (forever maploop
+		     (if (>=i ix (mapstring_size map)) (exit maploop))
+		     (let ( (curval (mapstring_nth_val map ix)) )
+		       (if curval 
+			   (if (null (f curval))
+			       (exit maploop curval)
+			     )))
+		     (setq ix (+i ix 1))
+		     )))))
+
+
+;;; iterator on a list, if the called f returns nil the iteration is stopped
+(defun list_iterate (lis f)
+  (if (is_list lis)
+      (if (is_closure f)
+	  (let ( (curpair (list_first lis)) )
+	    (forever lisloop
+		     (if (not (is_pair curpair)) (exit lisloop))
+		     (let ( (curelem (pair_head curpair)) )
+		       (if (null (f curelem)) (exit lisloop curelem)))
+		       (setq curpair (pair_tail curpair)))))))
+
+;; add to a destination list a source list
+(defun list_append2list (dlist slist)
+  (or (is_list slist) (return dlist))
+  (or (is_list dlist) (setq dlist (make_list discr_list)))
+  (list_iterate slist 
+		(lambda (e) (list_append dlist e) slist))
+  dlist)
+
+;;; iterator on a pairlist  if the called f returns nil the iteration is stopped
+(defun pairlist_iterate (pair f)
+      (if (is_closure f)
+	  (forever pairloop
+		   (or (is_pair pair) (exit pairloop))
+		     (let ( (curelem (pair_head pair)) )
+		       (if (null (f curelem)) (exit pairloop curelem)))
+		       (setq pair (pair_tail pair)))))
+		   
+;;; map on a list (list_map lis f) where lis is (e1 ... en) is ((f e1) .... (f en))
+(defun list_map (lis f)
+;  (debug_msg "list_map lis" lis)
+;  (debug_msg "list_map f" f)
+  (and (is_list lis)
+       (is_closure f)
+       (let ( (reslis (make_list discr_list)) 
+	      (curpair (list_first lis)) )
+	 (forever lisloop
+		  (if (not (is_pair curpair)) (exit lisloop))
+		  (let ( (curelem (pair_head curpair)) )
+		    (list_append reslis (f curelem)))
+		  (setq curpair (pair_tail curpair)))
+;	 (debug_msg "list_map reslis" reslis)
+	 reslis
+	 )))
+		    
+;;; translate a list to a multiple - with each element transformed by a function f (default the identity)
+(defun list_to_multiple (lis disc f)
+  (or disc (setq disc discr_multiple))
+  (if (is_list lis)
+      (let ( (:long ln (list_length lis))
+	     (tup (make_multiple disc ln))
+	     (ixb (make_integerbox discr_integer 0))
+	     (curpair (list_first lis)) )
+	(list_iterate 
+	 lis
+	 (lambda (c) 
+	   (let ( (:long ix (get_int ixb)) 
+		  (tc (if (is_closure f) (f c) c))
+		  )
+	     (put_int ixb (+i ix 1))
+	     (multiple_put_nth tup ix tc))
+	   tup
+	   ))
+	tup
+	)))
+;;; translate a pairlist to a tuple - with each element transformed by a function f (default the identity)
+(defun pairlist_to_multiple (pair disc f)
+  (or disc (setq disc discr_multiple))
+  (let ( (:long ln 0) )
+    (let ( (curpair pair) )
+      (forever loopln
+	       (or (is_pair curpair) (exit loopln))
+	       (setq ln (+i ln 1))
+	       (setq curpair (pair_tail curpair))))
+    (let ( (tup (make_multiple disc ln))
+	   (:long ix 0) 
+	   (curpair pair)
+	   )
+      (forever loopfi
+	       (or (is_pair curpair) (exit loopfi))
+	       (let ( (c (pair_head curpair))
+		      (tc (if (is_closure f) (f c) c)) )
+		 (multiple_put_nth tup ix tc)
+		 (setq ix (+i ix 1))
+		 (setq curpair (pair_tail curpair))))
+      tup
+      )))
+
+;;; iterator on tuple , if the called f returns nil the iteration is stopped
+;;; the function is called with the component and its index
+(defun multiple_iterate (tup f)
+  (if (is_multiple tup)
+      (if (is_closure f)
+	  (let ( (:long ln (multiple_length tup))
+		 (:long ix 0) )
+;	    (messagenum_dbg "multipliterate ln" ln)
+	    (forever tuploop
+		     (if (>=i ix ln) (exit tuploop))
+;		     (messagenum_dbg "multipliterate ix" ix)
+		     (let ( (curcomp (multiple_nth tup ix)) )
+		       (if (null (f curcomp ix)) (exit tuploop curcomp)))
+		     (setq ix (+i ix 1)))))))
+
+;;; map on tuple -- with tup= (t0 t1 ... t_n-1) return ((f t0 0) (f t1 1) ... (f t_n-1 n-1)
+(defun multiple_map (tup f)
+  (if (is_multiple tup)
+      (if (is_closure f)
+	  (let ( (:long ln (multiple_length tup))
+		 (:long ix 0) 
+		 (res (make_multiple discr_multiple ln))
+		 )
+	    (forever tuploop
+		     (if (>=i ix ln) (exit tuploop))
+		     (let ( (curcomp (multiple_nth tup ix)) )
+		       (multiple_put_nth res ix (f curcomp ix)))
+		     (setq ix (+i ix 1)))
+	    res))))
+		     
+
+;;; installation of a method in a class or discriminant
+(defun install_method (cla sel fun)
+  (if (is_a cla class_discr)
+      (if (is_a sel class_selector)
+	  (if (is_closure fun)
+	      (let 
+		  ( (mapdict 
+		     (unsafe_get_field :disc_methodict cla)) )
+		(if (is_mapobject mapdict)
+		    (mapobject_put mapdict sel fun)
+		  (let ( (newmapdict (make_mapobject discr_methodmap 30)) )
+		    (mapobject_put newmapdict sel fun)
+		    (unsafe_put_fields cla :disc_methodict newmapdict)
+		    )))))))
+
+
+(defclass class_debuginfo 
+  :super class_root
+  :fields (dbgi_sbuf 			;the produced stringbuf
+	   dbgi_occmap ;the occurrence map (to avoid outputing twice the same object)
+	   dbgi_maxdepth ;the boxed integer maximal depth
+	   )
+)
+
+;;; selector to output for debugging
+;;; reciever: any object or value
+;;; arguments: the debuginfo (instance of class_debuginfo), the depth (long)
+(defselector dbg_output class_selector
+  :named_name  (stringconst2val discr_namestring "DBG_OUTPUT"))
+
+
+;;; selector to output again for debugging
+;;; reciever: any object (already output)
+;;; arguments: the debuginfo (instance of class_debuginfo), the depth (long)
+(defselector dbg_outputagain class_selector
+  :named_name  (stringconst2val discr_namestring "DBG_OUTPUTAGAIN"))
+
+
+;; somehow needed to be a separate function because of a bug in cold
+(defun dbg_outobject (obj dbgi :long depth)
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (let ( (occmap (unsafe_get_field :dbgi_occmap dbgi)) )
+    ;(messageval_dbg "Dbg_OutObj obj" obj)
+    (if (is_mapobject occmap)
+	(let ( (occ (mapobject_get occmap obj)) )
+	  (checkcallstack_msg "in dbg_outobject")
+	  ;(messageval_dbg "Dbg_OutObj occ" occ)
+	  (if (is_integerbox occ)
+	      (progn
+		;(messageval_dbg "Dbg_Out,Again obj" obj)
+		(dbg_outputagain obj dbgi depth)
+		(put_int occ (+i (get_int occ) 1))
+		)
+	    (let ( (newocc (make_integerbox discr_integer 1)) )
+	      (mapobject_put occmap obj newocc)
+	      (checkcallstack_msg "in dbg_outobject output")
+	      (dbg_output obj dbgi depth)
+	      )))))
+  )
+
+(defun dbg_out (obj dbgi  :long depth) 
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (checkcallstack_msg "start dbg_out")
+  (let ( (sbuf (unsafe_get_field :dbgi_sbuf dbgi))
+	 (discr (discrim obj))
+	 )
+    (if (need_dbg 0)
+	(if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
+	    (if (is_object obj)
+		(progn
+		  (checkcallstack_msg "start dbg_out outobject")
+		  (dbg_outobject obj dbgi depth)
+		  )
+	      (if obj
+		  (progn
+		    (checkcallstack_msg "start dbg_out output")
+		    (dbg_output obj dbgi depth)
+		  )
+		(if (is_strbuf sbuf) (add2sbuf_strconst sbuf "?_?")
+		  )))
+	  (if (is_strbuf sbuf)
+	      (add2sbuf_strconst sbuf "..")
+	  )))))
+  
+;; utility to dump fields in an object from a given rank
+(defun dbgout_fields (obj dbgi :long depth rank)
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (assert_msg "check obj" (is_object obj))
+  (let ( (:long nbf (object_length obj)) 
+	 (cla (discrim obj))
+	 (:long ix rank)
+	 (clafieldseq (unsafe_get_field :class_fields cla))
+	 (sbuf  (unsafe_get_field :dbgi_sbuf dbgi))
+	 )
+    (assert_msg "check sbuf" (is_strbuf sbuf))
+    (if (<i ix 0) (setq ix 0))
+    (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
+	(forever fldloop
+		 (if (>=i ix nbf)
+		     (exit fldloop))
+		 (let ( (curfld (multiple_nth clafieldseq ix))
+			(curval (object_nth_field obj ix))
+			)
+		   (if curval
+		       (let ( (:long curulen (strbuf_usedlength sbuf)) )
+			 (add2sbuf_indent sbuf depth)
+			 (add2sbuf_string sbuf (unsafe_get_field :named_name curfld))
+			 (add2sbuf_strconst sbuf "=")
+			 (dbg_out curval dbgi (+i depth 1))
+			 (let ( (:long deltalen (-i (strbuf_usedlength sbuf) curulen)) )
+			   (if  (>i deltalen 100)
+			       (add2sbuf_indentnl sbuf depth)))
+			 )))
+		 (setq ix (+i ix 1))
+		 )
+      )))
+
+
+;; string debug output
+(defun dbgout_string_method (self dbgi :long depth)
+;  (message_dbg "DbgOut_String")
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (if (need_dbg 0) 
+      (let ( (dis (discrim self)) 
+	     (sbuf  (unsafe_get_field :dbgi_sbuf dbgi))
+	     )
+	(if (== dis DISCR_STRING)
+	    (progn
+	      (add2sbuf_strconst sbuf " \"")
+	      (add2sbuf_cencstring sbuf self)
+	      (add2sbuf_strconst sbuf "\"")
+	      )
+	  (progn
+	    (add2sbuf_strconst sbuf " |")
+	    (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
+	    (add2sbuf_strconst sbuf "\"")
+	    (add2sbuf_cencstring sbuf self)
+	    (add2sbuf_strconst sbuf "\"")
+	    )))))
+
+(install_method discr_string  dbg_output dbgout_string_method)
+(install_method discr_namestring  dbg_output dbgout_string_method)
+(install_method discr_verbatimstring  dbg_output dbgout_string_method)
+
+;; integer debug output
+(defun dbgout_integer_method (self dbgi :long depth)
+;  (message_dbg "DbgOut_Integer")
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (if (need_dbg 0) 
+      (let ( (dis (discrim self)) 
+	     (sbuf  (unsafe_get_field :dbgi_sbuf dbgi))
+	     )
+	(if (== dis DISCR_INTEGER)
+	    (progn 
+	      (add2sbuf_strconst sbuf " #")
+	      (add2sbuf_longdec sbuf (get_int self)))
+	  (progn
+	    (add2sbuf_strconst sbuf " |")
+	    (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
+	    (add2sbuf_strconst sbuf "#")
+	    (add2sbuf_longdec sbuf (get_int self)))
+	    ))))
+
+(install_method discr_integer dbg_output dbgout_integer_method)
+(install_method discr_charinteger dbg_output dbgout_integer_method)
+
+;; mixint debug value
+(defun dbgout_mixint_method (self dbgi :long depth)
+;  (message_dbg "DbgOut_Mixint")
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (if (need_dbg 0) 
+      (let ( (dis (discrim self)) 
+	    (sbuf  (unsafe_get_field :dbgi_sbuf dbgi))
+	     )
+	(if (== dis DISCR_MIXEDINT)
+	    (progn 
+	      (add2sbuf_strconst sbuf " #[")
+	      (add2sbuf_longdec sbuf (get_int self)))
+	    (progn
+	      (add2sbuf_strconst sbuf " |")
+	      (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
+	      (add2sbuf_strconst sbuf "#[")
+	      (add2sbuf_longdec sbuf (get_int self)))
+	    )
+	(if  (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
+	     (progn
+	       (add2sbuf_strconst sbuf ",")
+	       (dbg_out (mixint_val self) dbgi (+i depth 1))
+	       )
+	       (add2sbuf_strconst sbuf ",..")
+	     )
+	(add2sbuf_strconst sbuf "]")
+	)))
+(install_method discr_mixedint dbg_output dbgout_mixint_method)
+
+;; multiple debug out
+(defun dbgout_multiple_method (self dbgi :long depth)
+;  (message_dbg "DbgOut_Multiple")
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (if (need_dbg 0)
+      (let ( (dis (discrim self)) 
+	     (sbuf (unsafe_get_field :dbgi_sbuf dbgi))
+	     )
+	(if (== dis DISCR_MULTIPLE)
+	    (add2sbuf_strconst sbuf " *")
+	  (progn
+	    (add2sbuf_strconst sbuf " |")
+	    (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
+	    (add2sbuf_strconst sbuf "*")))
+	(let ( (:long ln (multiple_length self)) )
+	  (add2sbuf_longdec sbuf ln)
+	  (add2sbuf_strconst sbuf "[")
+	  (if (need_dbg depth)
+	      (let ( (:long ix 0) )
+		(forever comploop
+			 (if (>=i ix ln) (exit comploop))
+			 (add2sbuf_indent sbuf depth)
+			 (let ( (:long curulen (strbuf_usedlength sbuf)) )
+			   (dbg_out  (multiple_nth self ix) dbgi (+i 1 depth))
+			   (and (>i (-i (strbuf_usedlength sbuf) curulen) 100)
+				(<i ix (-i ln 1))
+				(add2sbuf_indentnl sbuf (+i 1 depth))))
+			 (setq ix (+i ix 1))
+			 ))
+	    (add2sbuf_strconst sbuf "..")
+	    )
+	  (add2sbuf_strconst sbuf "]")
+	  ))))
+
+(install_method discr_multiple dbg_output dbgout_multiple_method)
+
+;; routine debug out - don't print the routine components
+(defun dbgout_routine_method (self dbgi :long depth)
+;  (message_dbg "DbgOut_Routine")
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (if (need_dbg 0)
+      (let ( (dis (discrim self)) 
+	     (sbuf (unsafe_get_field :dbgi_sbuf dbgi))
+	     )
+	(if (== dis DISCR_ROUTINE)
+	    (add2sbuf_strconst sbuf " *rou[%")
+	  (progn
+	    (add2sbuf_strconst sbuf " |")
+	    (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
+	    (add2sbuf_strconst sbuf "[%")))
+	(add2sbuf_routinedescr sbuf self)
+	  (add2sbuf_strconst sbuf "%]")
+	)
+))
+
+(install_method discr_routine dbg_output dbgout_routine_method)
+
+;; closure debug out 
+(defun dbgout_closure_method (self dbgi :long depth)
+;  (message_dbg "DbgOut_Closure")
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (if (need_dbg 0)
+      (let ( (dis (discrim self)) 
+	     (:long oldmaxdepth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
+	     (sbuf  (unsafe_get_field :dbgi_sbuf dbgi)) )
+	(if (== dis DISCR_CLOSURE)
+	    (add2sbuf_strconst sbuf " *clo<")
+	  (progn
+	    (add2sbuf_strconst sbuf " |")
+	    (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
+	    (add2sbuf_strconst sbuf "*clo<")))
+	(put_int (unsafe_get_field :dbgi_maxdepth dbgi) 0)
+	(dbg_out (closure_routine self) dbgi 0)
+	(put_int (unsafe_get_field :dbgi_maxdepth dbgi) oldmaxdepth)
+	(if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
+	    (let ((:long ix 0))
+	      (add2sbuf_strconst sbuf "/")
+	      (add2sbuf_longdec sbuf (closure_size self))
+	      (forever outloop
+		       (if (>=i ix (closure_size self))
+			   (exit outloop))
+		       (add2sbuf_indent sbuf depth)
+		       (let ( (:long curulen (strbuf_usedlength sbuf)) )
+			 (dbg_out (closure_nth self ix) dbgi (+i depth 1))
+			 (if (>i (-i (strbuf_usedlength sbuf) curulen) 100)
+			     (add2sbuf_indentnl sbuf (+i 1 depth))))
+		       (setq ix (+i ix 1))
+		       )))
+	(add2sbuf_strconst sbuf ">")
+	)))
+
+(install_method discr_closure dbg_output dbgout_closure_method)      
+
+
+
+;; list debug out 
+(defun dbgout_list_method (self dbgi :long depth)
+					;  (message_dbg "DbgOut_List")
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (if (need_dbg 0)
+      (let ( (dis (discrim self)) 
+	     (sbuf  (unsafe_get_field :dbgi_sbuf dbgi)) )
+	(if (== dis DISCR_LIST)
+	    (add2sbuf_strconst sbuf " *li(")
+	  (progn
+	    (add2sbuf_strconst sbuf " |")
+	    (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
+	    (add2sbuf_strconst sbuf "(")))
+	(let (
+	      (curpair (list_first self))
+	      (:long ix 0) 
+	      )
+	  (checkcallstack_msg "before loop dbgout_list_method")
+	  (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
+	      (forever listloop
+		       (checkcallstack_msg "start loop dbgout_list_method")
+		       (if (>i ix 300)
+			   (progn
+			     (add2sbuf_strconst sbuf "...")
+			     (exit listloop)))
+		       (if (not (is_pair curpair)) (exit listloop))
+		       (add2sbuf_indent sbuf depth)
+		       (let ( (:long curulen (strbuf_usedlength sbuf)) )
+			 (dbg_out (pair_head curpair) dbgi (+i depth 1))
+			 (setq curpair (pair_tail curpair))
+			 (checkcallstack_msg "near endloop dbgout_list_method")
+			 (if curpair
+			     (setq ix (+i ix 1))
+			   (exit listloop))
+			 (if (>i (-i (strbuf_usedlength sbuf) curulen) 100)
+			     (add2sbuf_indentnl sbuf (+i 1 depth))))
+		       ))
+	  (checkcallstack_msg "end dbgout_list_method")
+	  (add2sbuf_strconst sbuf ")")))
+    ))
+(install_method discr_list dbg_output dbgout_list_method)      
+
+;; pair debug output
+(defun dbgout_pair_method (self dbgi :long depth)
+;  (message_dbg "DbgOut_Pair")
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (if (need_dbg 0)
+      (let ( (dis (discrim self)) 
+	     (sbuf  (unsafe_get_field :dbgi_sbuf dbgi)) )
+	(if (== dis DISCR_PAIR)
+	    (add2sbuf_strconst sbuf " *pa(.")
+	  (progn
+	    (add2sbuf_strconst sbuf " |")
+	    (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
+	    (add2sbuf_strconst sbuf "(.")))
+       (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
+	   (progn
+	     (dbg_out (pair_head self) dbgi (+i depth 1))
+	     (add2sbuf_indent sbuf depth)
+	     (dbg_out (pair_tail self) dbgi (+i depth 1))))
+       (add2sbuf_strconst sbuf ".)"))))
+	
+(install_method discr_pair dbg_output dbgout_pair_method)      
+
+
+;;; the cold compiler prefers this way... to have an internal function
+;;; to output an entry...
+(defun dbgoutinternal_mapobj_entry (at va dbgi nextdepthbox)
+  (let ( (:long nextdepth (get_int nextdepthbox))
+	 (:long oldmaxdepth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
+	 (sbuf  (unsafe_get_field :dbgi_sbuf dbgi)) )
+    (assert_msg "check sbuf" (is_strbuf sbuf))
+    (add2sbuf_indentnl sbuf nextdepth)
+    (add2sbuf_strconst sbuf "** ")  
+    (put_int (unsafe_get_field :dbgi_maxdepth dbgi) 0)
+    (dbg_outobject at dbgi nextdepth)
+    (put_int (unsafe_get_field :dbgi_maxdepth dbgi) oldmaxdepth)
+    (add2sbuf_strconst sbuf " ==")  
+    (add2sbuf_indent sbuf (+i nextdepth 1))
+    (dbg_out va dbgi nextdepth)
+    (add2sbuf_strconst sbuf "; ")
+    ))
+
+(defun dbgout_mapobject_method (self dbgi :long depth)
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (if (need_dbg 0)
+      (let ( (dis (discrim self)) 
+	     (sbuf  (unsafe_get_field :dbgi_sbuf dbgi))
+	     )
+	(if (== dis DISCR_MAPOBJECTS)
+	    (add2sbuf_strconst sbuf " {")
+	  (progn
+	    (add2sbuf_strconst sbuf " |")
+	    (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
+	    (add2sbuf_strconst sbuf "{")))
+	(add2sbuf_strconst sbuf "/")
+	(add2sbuf_longdec sbuf (mapobject_count self))
+	(if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
+	    (let (
+		  (nextdepthbox (make_integerbox discr_integer (+i 1 depth)))
+		  )
+	      (mapobject_iterate 
+	       self
+	       (lambda (at va)
+		 (dbgoutinternal_mapobj_entry at va dbgi nextdepthbox)
+		 at
+		 ))))
+	(add2sbuf_strconst sbuf "}"))))
+(install_method discr_mapobjects dbg_output dbgout_mapobject_method)
+
+;; multiple debug out
+(defun dbgout_mapstring_method (self dbgi :long depth)
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (if (need_dbg 0)
+      (let ( (dis (discrim self)) 
+	     (sbuf (unsafe_get_field :dbgi_sbuf dbgi))
+	     (:long ix 0)
+	     )
+	(if (== dis DISCR_MAPSTRINGS)
+	    (add2sbuf_strconst sbuf " <(")
+	  (progn
+	    (add2sbuf_strconst sbuf " |")
+	    (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
+	    (add2sbuf_strconst sbuf "<(")))
+	(add2sbuf_strconst sbuf "/")
+	(add2sbuf_longdec sbuf (mapstring_count self))
+	(forever mapstrloop
+		 (if (>i ix (mapstring_size self)) (exit mapstrloop))
+		 (let ( (curstr (mapstring_nth_attrstr self discr_string ix))
+			(curat (mapstring_nth_val self ix)) )
+		   (if (and (is_string curstr) (notnull curat))
+		       (progn
+			 (add2sbuf_indentnl sbuf (+i depth 1))
+			 (add2sbuf_strconst sbuf "!*")
+			 (dbg_out curstr dbgi (+i depth 1))
+			 (add2sbuf_strconst sbuf " => ")  
+			 (add2sbuf_indent sbuf (+i depth 1))
+			 (dbg_out curat dbgi (+i depth 2))
+			 )))
+		 (setq ix (+i ix 1)))
+	(add2sbuf_strconst sbuf " )>"))))
+(install_method discr_mapstrings dbg_output dbgout_mapstring_method)
+
+;;;; generic object debug
+(defun dbgout_anyobject_method (self dbgi :long depth)
+;  (message_dbg "DbgOut_AnyObject")
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (if (need_dbg 0)
+      (let ( (dis (discrim self)) 
+	     (sbuf  (unsafe_get_field :dbgi_sbuf dbgi)) ) 
+	(add2sbuf_strconst sbuf " |")
+	(add2sbuf_string sbuf (unsafe_get_field :named_name dis))
+	(add2sbuf_strconst sbuf "/")
+	(add2sbuf_longhex sbuf (obj_hash self))
+	(let ( (:long onum (obj_num self)) )
+	  (if onum
+	      (progn
+		(add2sbuf_strconst sbuf "#")
+		(add2sbuf_longdec sbuf onum))))
+	(add2sbuf_strconst sbuf "{")
+	(if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
+	    (dbgout_fields self dbgi (+i depth 1) 0)
+	  )
+	(add2sbuf_strconst sbuf "}")
+	)))
+(install_method class_root  dbg_output dbgout_anyobject_method)
+
+;;;; generic value debug
+(defun dbgout_anyrecv_method (self dbgi :long depth)
+;  (message_dbg "DbgOut_AnyObject")
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (if (need_dbg 0)
+      (let ( (dis (discrim self)) 
+	     (sbuf  (unsafe_get_field :dbgi_sbuf dbgi)) ) 
+	(add2sbuf_strconst sbuf " ?.")
+	(if (is_a dis class_named) (add2sbuf_string sbuf (unsafe_get_field :named_name dis)))
+	(add2sbuf_strconst sbuf ".? ")
+)))
+(install_method discr_anyrecv dbg_output dbgout_anyrecv_method)
+
+;;; generic object debug outputagain
+(defun dbgoutagain_anyobject_method (self dbgi :long depth)
+;  (message_dbg "DbgOutAgain_AnyObject")
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (if (need_dbg 0)
+      (let ( (dis (discrim self)) 
+	     (sbuf  (unsafe_get_field :dbgi_sbuf dbgi)) )  
+	(add2sbuf_strconst sbuf " ^^|")
+	(add2sbuf_string sbuf (unsafe_get_field :named_name dis))
+	(add2sbuf_strconst sbuf "/")
+	(add2sbuf_longhex sbuf (obj_hash self))
+	)))
+(install_method class_root  dbg_outputagain dbgoutagain_anyobject_method)
+	
+;;;; named object debug
+(defun dbgout_namedobject_method (self dbgi :long depth)
+;  (message_dbg "DbgOut_NamedObject")
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (if (need_dbg 0)
+      (let ( (dis (discrim self)) 
+	     (sbuf  (unsafe_get_field :dbgi_sbuf dbgi))
+	     (onam (unsafe_get_field :named_name self))
+	     (oprop (unsafe_get_field :prop_table self))
+	     ) 
+	(assert_msg "check sbuf" (is_strbuf sbuf))
+	(add2sbuf_strconst sbuf "`")
+	(add2sbuf_string sbuf onam)
+	(add2sbuf_strconst sbuf "|")
+	(add2sbuf_string sbuf (unsafe_get_field :named_name dis))
+	(add2sbuf_strconst sbuf "/")
+	(add2sbuf_longhex sbuf (obj_hash self))
+	(if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
+	    (let ( (:long onum (obj_num self)) )
+	      (if onum
+		  (progn
+		    (add2sbuf_strconst sbuf "#")
+		    (add2sbuf_longdec sbuf onum)))
+	      (add2sbuf_strconst sbuf "{")
+	      (if oprop
+		  (progn 
+		    (add2sbuf_strconst sbuf "prop=")
+		    (dbg_out oprop dbgi (+i depth 2))
+		    ))
+	      (dbgout_fields self dbgi (+i depth 1) 2)
+	      (add2sbuf_strconst sbuf "}")
+	      )))))
+(install_method class_named  dbg_output dbgout_namedobject_method)
+
+;;;; named object debug outputagain
+(defun dbgoutagain_namedobject_method (self dbgi :long depth)
+;  (message_dbg "DbgOutAgain_NamedObject")
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (if (need_dbg 0)
+      (let ( (dis (discrim self)) 
+	     (sbuf  (unsafe_get_field :dbgi_sbuf dbgi))
+	     (onam (unsafe_get_field :named_name self)) 
+	     )
+	(add2sbuf_strconst sbuf " ^^`")
+	(add2sbuf_string sbuf onam)
+	(add2sbuf_strconst sbuf "|")
+	(add2sbuf_string sbuf (unsafe_get_field :named_name dis))
+	(add2sbuf_strconst sbuf "/")
+	(add2sbuf_longhex sbuf (obj_hash self))
+	)))
+(install_method class_named dbg_outputagain dbgoutagain_namedobject_method)
+
+;;;; symbol output debug & again
+(defun dbgout_symbol_method (self dbgi :long depth)
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (assert_msg "check self" (is_a self class_symbol))
+  (if (<=i depth 0)
+      (dbgout_namedobject_method self dbgi 0)
+    (dbgoutagain_symbol_method self dbgi depth)))
+(install_method class_symbol dbg_output dbgout_symbol_method)
+
+(defun dbgoutagain_symbol_method (self dbgi :long depth)
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (assert_msg "check self" (is_a self class_symbol))
+    (let ( (sbuf  (unsafe_get_field :dbgi_sbuf dbgi))
+	   (onam (unsafe_get_field :named_name self))
+	   )	
+      (if (need_dbg 0)
+	  (progn
+	    (add2sbuf_strconst sbuf " $")
+	    (add2sbuf_string sbuf onam)
+	    (add2sbuf_strconst sbuf "/")
+	    (add2sbuf_longhex sbuf (obj_hash self))))))
+(install_method class_symbol dbg_outputagain dbgoutagain_symbol_method)
+
+;;;; keyword output debug & again
+(defun dbgout_keyword_method (self dbgi :long depth)
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (assert_msg "check self" (is_a self class_keyword))
+  (if (<=i depth 0)
+      (dbgout_namedobject_method self dbgi 0)
+    (dbgoutagain_keyword_method self dbgi depth)))
+(install_method class_keyword dbg_output dbgout_keyword_method)
+
+(defun dbgoutagain_keyword_method (self dbgi :long depth)
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (assert_msg "check self" (is_a self class_keyword))
+    (let ( (sbuf  (unsafe_get_field :dbgi_sbuf dbgi))
+	   (onam (unsafe_get_field :named_name self))
+	   )	
+      (if (need_dbg 0)
+	  (progn
+	    (add2sbuf_strconst sbuf " $:")
+	    (add2sbuf_string sbuf onam)
+	    (add2sbuf_strconst sbuf "/")
+	    (add2sbuf_longhex sbuf (obj_hash self))))))
+(install_method class_keyword dbg_outputagain dbgoutagain_keyword_method)
+
+;;;; clonedsymbol output debug & again
+(defun dbgout_clonedsymbol_method (self dbgi :long depth)
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (assert_msg "check self" (is_a self class_clonedsymbol))
+  (if (<=i depth 0)
+      (dbgout_namedobject_method self dbgi 0)
+    (dbgoutagain_clonedsymbol_method self dbgi depth)
+    ))
+(install_method class_clonedsymbol dbg_output dbgout_clonedsymbol_method)
+
+(defun dbgoutagain_clonedsymbol_method (self dbgi :long depth)
+  (if (need_dbg 0)
+      (let ( (dis (discrim self)) 
+	     (sbuf  (unsafe_get_field :dbgi_sbuf dbgi))
+	     (ourank (unsafe_get_field :csym_urank self))
+	     (:long lrk (get_int ourank))
+	     (onam (unsafe_get_field :named_name self)) )
+	(add2sbuf_strconst sbuf " $$")
+	(add2sbuf_string sbuf onam)
+	(add2sbuf_strconst sbuf ":")
+	(add2sbuf_longdec sbuf lrk)
+	(add2sbuf_strconst sbuf "/")
+	(add2sbuf_longhex sbuf (obj_hash self)))))
+(install_method class_clonedsymbol dbg_outputagain dbgoutagain_clonedsymbol_method)
+
+;;;; ctype output debug & again
+(defun dbgout_ctype_method (self dbgi :long depth)
+  (assert_msg "check dbgi" (is_a dbgi class_debuginfo))
+  (assert_msg "check self" (is_a self class_ctype))
+  (if (<=i depth 0)
+      (dbgout_namedobject_method self dbgi 0)
+    (dbgoutagain_ctype_method self dbgi depth)
+))
+(install_method class_ctype dbg_output dbgout_ctype_method)
+
+(defun dbgoutagain_ctype_method (self dbgi :long depth)
+  (if (need_dbg 0)
+	  (let ( (dis (discrim self)) 
+		 (sbuf  (unsafe_get_field :dbgi_sbuf dbgi))
+		 (onam (unsafe_get_field :named_name self)) )
+	    (add2sbuf_strconst sbuf " $!")
+	    (add2sbuf_string sbuf onam)
+	    (add2sbuf_strconst sbuf "!/")
+	    (add2sbuf_longhex sbuf (obj_hash self)))))
+(install_method class_ctype dbg_outputagain dbgoutagain_ctype_method)
+  
+;;;;;;;;;;;;;;;;;;;;;;;; debug message function
+(defprimitive the_dbgcounter () :long "basilys_dbgcounter")
+(defprimitive increment_dbgcounter () :void "(void) ++basilys_dbgcounter")
+
+(defun debug_msg (msgstr val :long count)
+  (if (need_dbg 0) 
+      (let ( (:long dbgcounter (progn (increment_dbgcounter) (the_dbgcounter)))
+	     (sbuf (make_strbuf discr_strbuf)) 
+	     (occmap (make_mapobject discr_mapobjects 50))
+	     (boxedmaxdepth (make_integerbox discr_integer 14))
+	     (dbgi (make_instance class_debuginfo
+				  :dbgi_sbuf sbuf
+				  :dbgi_occmap occmap
+				  :dbgi_maxdepth boxedmaxdepth))
+	     )
+;	(message_dbg "Debug_Msg+")
+	(outnum_dbg "!*#" dbgcounter ":")
+	(outstr_dbg msgstr)
+	(if (>i count 0) (outnum_dbg " !" count ": "))
+	(dbg_out val dbgi 0)
+	(outstrbuf_dbg sbuf)
+	(outnewline_dbg)
+;	(message_dbg "Debug_Msg-")
+	)))
+
+;;;; the class for environments
+(defclass class_environment
+  :super class_root
+  :fields (env_bind			;the map of bindings
+	   env_prev			;the previous environment
+	   env_proc			;the procedure of this environment
+))
+
+;; the (super-)class of any binding
+(defclass class_any_binding
+  :super class_root
+  :fields (binder)
+)
+
+;;; superclass of exported bindings
+(defclass class_exported_binding
+  :super class_any_binding
+  :fields ( )
+)
+
+;; macro binding
+(defclass class_macro_binding
+  :super class_exported_binding
+  :fields (mbind_expanser))
+
+
+;; value binding - as exported 
+(defclass class_value_binding
+  :super class_exported_binding
+  :fields (vbind_value
+))
+
+; formal binding (used in generated defprimitive)
+(defclass class_formal_binding
+  :super class_any_binding
+  :fields (fbind_type)
+  ;;the obj_num is the argument rank
+  :predef CLASS_FORMAL_BINDING)
+
+
+;;; fixed bindings are defined in a compilation unit and can be implemented as constants in routine
+(defclass class_fixed_binding
+  :super class_any_binding
+  :fields ()
+)
+
+;; selector binding
+(defclass class_selector_binding
+  :super class_fixed_binding
+  :fields (sbind_selectordef 		;the "source" defselector
+	   sbind_selectordata		;the compiled data
+	   ;; maybe we need an selectorval for the actual value
+	   )
+)
+
+;; primitive binding
+(defclass class_primitive_binding
+  :super class_fixed_binding
+  :fields (pbind_primdef		;the source defprimitive
+	   pbind_primitive		;the primitive proper
+	   pbind_primdata		;the primitive data as compiled
+))
+
+
+;; function binding
+(defclass class_function_binding
+  :super class_fixed_binding
+  :fields (fubind_defun ;the source definition
+	   fubind_fundata		;compiled data
+))
+
+;; class binding
+(defclass class_class_binding
+  :super class_fixed_binding
+  :fields (cbind_defclass ;the source definition
+	   cbind_class			;the built class
+	   cbind_cladata		;compiled data
+))
+
+;; field binding
+(defclass class_field_binding
+  :super class_fixed_binding
+  :fields (flbind_clabind		;the class binding
+	   flbind_field			;the field proper
+	   flbind_fdata			;the compiled field data
+))
+
+;; let binding
+(defclass class_let_binding
+  :super class_any_binding
+  :fields (letbind_type			;the ctype 
+	   letbind_expr			;the expression
+	   letbind_loc			;the optional src location
+	   ))
+
+;; normalized let binding
+(defclass class_normlet_binding
+  :super class_let_binding
+  :fields  ())				;no additional field, but letbind_expr is "normal"
+
+;; label binding
+(defclass class_label_binding
+  :super class_any_binding
+  :fields (labind_loc			;location of the label
+;;; following fields are filled later in the compilation phase
+	   labind_clonsy		;unique cloned symbol
+	   labind_res			;result localvar
+))
+
+;; make a fresh environment 
+(defun fresh_env (parenv)
+  (if (is_a parenv class_environment)
+      (make_instance class_environment 
+		     :env_bind (make_mapobject discr_mapobjects 6)
+		     :env_prev parenv)))
+
+;; the initial environment
+(definstance initial_environment class_environment
+  :env_bind  (make_mapobject discr_mapobjects 500)
+)
+
+;; find a binding inside an environment
+(defun find_env (env binder)
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check binder" (is_object binder))
+  (forever findloop
+	   (if (not (is_a env class_environment)) (exit findloop))
+	   (let ( (bindmap (unsafe_get_field :env_bind env)) )
+	     (assert_msg "check bindmap" (is_mapobject bindmap))
+	     (let ( (bnd (mapobject_get bindmap binder)) )
+	       (if bnd (exit findloop bnd))
+	       ))
+	   (setq env (unsafe_get_field :env_prev env))
+	   )
+  )
+
+; find a binding inside an environment and also returns the reversed list of enclosing procedures
+(defun find_enclosing_env (env binder)
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check binder" (is_object binder))
+  (let ( (proclist (make_list discr_list)) )
+  (forever findloop
+	   (if (not (is_a env class_environment)) (exit findloop))
+	   (let ( (bindmap (unsafe_get_field :env_bind env)) 
+		  (eproc (unsafe_get_field :env_proc env))
+		  )
+	     (assert_msg "check bindmap" (is_mapobject bindmap))
+	     (let ( (bnd (mapobject_get bindmap binder)) )
+	       (if bnd (return bnd proclist)))
+	     (if eproc (list_prepend proclist eproc))
+	     (setq env (unsafe_get_field :env_prev env))
+	       ))))
+
+;; put a binding at top of an environment
+(defun put_env (env binding)
+  (assert_msg "check env" (is_a env class_environment))
+  (if (not (is_a binding class_any_binding))
+      (progn
+	(debug_msg "put_env invalid binding" binding (the_callcount))
+	(shortbacktrace_dbg "put_env invalid binding" 15)))
+  (assert_msg "check binding" (is_a binding class_any_binding))
+  (let ( (bindmap (unsafe_get_field :env_bind env)) 
+	 (binder (unsafe_get_field :binder binding))
+	 )
+    (if (not (is_object binder))
+	(progn
+	  (debug_msg "put_env bad binder in binding" binding (the_callcount))
+	  (debug_msg "put_env bad binder" binder (the_callcount))
+	  (shortbacktrace_dbg "put_env  bad binder in binding" 5)))
+    (assert_msg "check bindmap" (is_mapobject bindmap))
+    (assert_msg "check binder" (is_object binder))
+    (mapobject_put bindmap binder binding)
+    ))
+
+;; overwrite a binding in the environment where it has been already bind
+(defun overwrite_env (env binding)
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check binding" (is_a binding class_any_binding))
+  (let ( (binder  (unsafe_get_field :binder binding)) )
+    (assert_msg "check binder" (is_object binder))
+    (forever findloop
+	     (if (not (is_a env class_environment)) (exit findloop))
+	     (let ( (bindmap (unsafe_get_field :env_bind env)) )
+	       (assert_msg "check bindmap" (is_mapobject bindmap))
+	       (let ( (oldbinding (mapobject_get bindmap binder)) )
+		 (if oldbinding 
+		     (progn 
+		       (mapobject_put bindmap binder binding)
+		       (exit findloop oldbinding))
+		   ))
+	       (setq env (unsafe_get_field :env_prev env))
+	       ))))
+
+;;;;;;;;;;;;;;;;;;;; source program elements
+(defclass class_src 
+  :super class_root
+  :fields (src_loc			;the source location (if any)
+	   )
+)
+
+
+;;; source application 
+(defclass class_src_apply
+  :super class_src
+  :fields (sapp_fun			;the function to apply
+	   sapp_args			;the arguments tuple
+	   ))
+
+;;; source primitive call
+(defclass class_src_primitive
+  :super class_src
+  :fields (sprim_oper			;the primitive operation
+	   sprim_args			;the arguments tuple
+	   ))
+
+;;; source progn
+(defclass class_src_progn
+  :super class_src
+  :fields (sprogn_body			;the body tuple
+))
+
+;;; source progn
+(defclass class_src_return
+  :super class_src
+  :fields (sreturn_body			;the body tuple
+))
+
+;;;; source setq
+(defclass class_src_setq
+  :super class_src
+  :fields (sstq_var
+	   sstq_expr))
+
+
+;;;; source quote
+(defclass class_src_quote
+  :super class_src
+  :fields (squoted
+))
+;;; superclass for all source definitions
+(defclass class_srcdef
+  :super class_src
+  :fields (sdef_name			;defined name
+))
+
+;;; superclass for all definitions with formal arglist
+(defclass class_srcdeformal
+  :super class_srcdef
+  :fields (sformal_args			;formal arguments binding tuple
+))
+
+;;;; define a function
+(defclass class_src_defun
+  :super class_srcdeformal
+  :fields (sfun_body			;body sequence
+))
+
+;;; define a primitive
+(defclass class_src_defprimitive
+  :super class_srcdeformal
+  :fields (sprim_type			;result type of primitive
+	   sprim_expansion		;primitive expansion
+))
+
+;; define an object (common to instance, class, selector)
+(defclass class_src_defobjcommon
+  :super class_srcdef
+  :fields (sobj_predef			;the predefined rank
+	   sobj_docstr			;documentation string
+))
+
+;; define a class 
+;;;; the class has been built (at compile time), but we need a
+;;;; srcdefclass to actually generate code
+(defclass class_src_defclass
+  :super class_src_defobjcommon
+  :fields (sclass_clabind		;the binding of the class
+	   sclass_superbind		;binding of superclass (or nil if none)
+	   sclass_fldbinds		;the sequence of (own field bindings)
+))
+
+
+;; define an instance
+(defclass class_src_definstance
+  :super class_src_defobjcommon
+  :fields (sinst_class			;the class of the instance
+	   sinst_clabind		;the classbinding of the instance
+	   sinst_objnum			;the object number symbol or integer
+	   sinst_fields			;the sequence of field assignment
+))
+
+;; a field assignment
+(defclass class_src_fieldassign
+  :super class_src
+  :fields (sfla_field			;the field 
+	   sfla_expr			;the expression
+))
+
+
+;; make an instance
+(defclass class_src_make_instance
+  :super class_src
+  :fields (smins_class			;the class to be instantiated
+	   smins_clabind		;its (class|value) binding
+	   smins_fields			;the sequence of field assignment
+))
+
+;;; source unsafe get field
+(defclass class_src_unsafe_get_field
+  :super class_src
+  :fields (suget_obj	     ;the object expression
+	   suget_field	     ;the field keyword
+))
+
+;; source unsafe put fields
+(defclass class_src_unsafe_put_fields
+  :super class_src
+  :fields (suput_obj	     ;the object expression
+	   suput_fields			;the sequence of field assignment
+))
+
+
+;; a conditional (if, and, cond)
+(defclass class_src_if
+  :super class_src
+  :fields (sif_test
+	   sif_then
+	   sif_else
+))
+
+
+;; an or
+;;; since (OR a1 a2) is (IF a1 a1 a2) we need to normalize it to avoid evaluating twice a1
+;;; so there is no normalized or... (only normalized if-s)
+(defclass class_src_or
+  :super class_src
+  :fields (sor_disj			;tuple of disjuncts
+))
+
+
+
+;;; letbinding source
+(defclass class_src_letbinding
+  :super class_src
+  :fields (sletb_type			;the type of the binding
+	   sletb_binder			;the binder (variable)
+	   sletb_expr			;the expression
+))
+
+;; let source
+(defclass class_src_let
+  :super class_src
+  :fields (slet_bindings		;the tuple of letbinding-s
+	   slet_body			;the body tuple 
+))
+
+;; lambda
+(defclass class_src_lambda
+  :super class_src 
+  :fields (slam_argbind			;tuple of argument bindings
+	   slam_body			;tuple for body
+))
+
+
+;;; forever & exit share a common label
+(defclass class_src_labelled
+  :super class_src
+  :fields (slabel_bind			;the label binding
+))
+
+;; forever
+(defclass class_src_forever
+  :super class_src_labelled
+  :fields (sfrv_body			;tuple for body
+))
+
+;; exit
+(defclass class_src_exit
+  :super class_src_labelled
+  :fields ( sexi_body			;tuple for body
+))
+
+
+;;;;;;;;;;;;;;;;;;;; first pass, macro expansion
+
+;;get the n-th son of a sexpr
+(defun sexpr_nth_son (sexp :long n)
+  (if (is_a sexp class_sexpr)
+      (let ( (:long ix 0)
+	     (curpair (list_first (unsafe_get_field :sexp_contents sexp)))
+	     )
+	(forever nthloop
+		 (or (is_pair curpair) (exit nthloop))
+		 (if (==i ix n) (exit nthloop (pair_head curpair)))
+		 (setq ix (+i ix 1))
+		 (setq curpair (pair_tail curpair))
+))))
+
+;;expand all but the first element of a list as a tuple
+(defun expand_restlist_as_tuple (arglist env mexpander)
+  (assert_msg "check end" (is_a env class_environment))
+  (assert_msg "check mexpander" (is_closure mexpander))
+  (assert_msg "check arglist" (is_list arglist))
+  (let ( (:long nbarg (list_length arglist))
+	 (:long ix 0)
+	 (curpair (pair_tail (list_first arglist)))
+	 (tup (make_multiple discr_multiple (-i nbarg 1)))
+	 )
+    (forever exploop
+	     (if (not curpair) (exit exploop))
+	     (assert_msg "check curpair" (is_pair curpair))
+	     (let ( (curarg (pair_head curpair)) 
+		    (curexp (macroexpand_1 curarg env mexpander))
+		    )
+	       (multiple_put_nth tup ix curexp)
+	       (setq ix (+i ix 1))
+	       (setq curpair (pair_tail curpair))
+	     ))
+    tup
+    ))
+
+;;expand all of a pairlist as a tuple
+(defun expand_pairlist_as_tuple (pair env mexpander)
+  (assert_msg "check end" (is_a env class_environment))
+  (assert_msg "check mexpander" (is_closure mexpander))
+  (let ( (:long nbarg (pair_listlength pair))
+	 (:long ix 0)
+	 (tup (make_multiple discr_multiple nbarg)) )
+    (forever exploop
+	     (if (not (is_pair pair)) (exit exploop))
+	     (let ( (curarg (pair_head pair)) 
+		    (curexp (macroexpand_1 curarg env mexpander))
+		    )
+	       (multiple_put_nth tup ix curexp)
+	       (setq ix (+i ix 1))
+	       (setq pair (pair_tail pair))
+	     ))
+    tup 
+))
+
+
+;;; expand an s-expression known to be an application
+(defun expand_apply (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check end" (is_a env class_environment))
+  (assert_msg "check mexpander" (is_closure mexpander))
+  (let ( (scont (unsafe_get_field :sexp_contents sexpr))
+	 (sloc (unsafe_get_field :loca_location sexpr))
+	 (soper (pair_head (list_first scont)))
+	 (xargtup (expand_restlist_as_tuple scont env mexpander))
+	 (xoper (if (is_a soper class_sexpr) 
+		    (macroexpand_1 soper env mexpander) 
+		  soper))
+	 )
+    (make_instance class_src_apply
+		   :src_loc sloc
+		   :sapp_fun xoper
+		   :sapp_args xargtup)))
+     
+
+;;; expand a keywordfun s-expression
+;;; not implemented yet, but might later be useful for stuff like
+;;;;; (:fieldname obj) to get a field
+;;;;; (:selector recv arg...) to send a message
+(defun expand_keywordfun (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check end" (is_a env class_environment))
+  (assert_msg "check mexpander" (is_closure mexpander))
+  (error_plain (unsafe_get_field :loca_location sexpr) "keywordoper not implemented")
+  (assert_msg "@@@  expand_keywordfun NOT IMPLEMENTED" 0)
+)
+
+(defun macroexpand_1 (sexpr env mexpander)
+  (if (null mexpander) (setq mexpander macroexpand_1))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check mexpander" (is_closure mexpander))
+  (if (is_a sexpr class_sexpr)
+      (let ( (scont (unsafe_get_field :sexp_contents sexpr))
+	     (soper (pair_head (list_first scont))) )
+	(cond ( (is_a soper class_symbol)
+		(let ( (opbind (find_env env soper)) )
+		  (cond ( (is_a opbind class_macro_binding)
+			  (let ( (mexp (unsafe_get_field :mbind_expanser opbind)) )
+			    (assert_msg "check mexp" (is_closure mexp))
+			    (mexp sexpr env mexpander)) )
+			( (is_a opbind class_selector_binding)
+			  (assert_msg "@@@ macroexpand_1 selector binding NOT IMPLEMENTED" 0)
+			  )
+			( (is_a opbind class_primitive_binding)
+			  (expand_primitive opbind sexpr env mexpander)
+			  )
+			(:else (expand_apply sexpr env mexpander))
+			)
+		  ))
+	      ( (is_a soper class_keyword)
+		(expand_keywordfun sexpr env mexpander) )
+	      ;; the empty list is expanded as nil
+	      ( (==i (list_length scont) 0)
+		())
+	      (:else 
+	       (expand_apply sexpr env mexpander))
+	      ))
+    sexpr))
+  
+;;; expand a primitive s-expression
+(defun expand_primitive (opbind sexpr env mexpander)
+  (assert_msg "check opbind" (is_a opbind class_primitive_binding))
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check end" (is_a env class_environment))
+  (assert_msg "check mexpander" (is_closure mexpander))
+  (let ( (scont (unsafe_get_field :sexp_contents sexpr))
+	 (sloc (unsafe_get_field :loca_location sexpr))
+	 (soper (pair_head (list_first scont)))
+	 (xargtup (expand_restlist_as_tuple scont env mexpander))
+	 (sprim (unsafe_get_field :pbind_primitive opbind))
+	 )
+    (assert_msg "check sprim" (is_a sprim class_primitive))
+    (make_instance class_src_primitive
+		   :src_loc sloc
+		   :sprim_oper sprim
+		   :sprim_args xargtup)))
+
+
+
+(defun macroexpand_toplevel_list (slist env)
+  ;; (messageval_dbg "macroexpand_toplevel_list Env" env)
+  (debug_msg "macroexpand_toplevel_list env" env (the_callcount)) 
+  (debug_msg "macroexpand_toplevel_list slist" slist (the_callcount)) 
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check slist" (is_list slist))
+  (let ( (xlist (list_map slist 
+			  (lambda (sexp) 
+			    (debug_msg "macroexpand_toplevel_list sexp" sexp (the_callcount))
+			    (macroexpand_1 sexp env macroexpand_1)))) )
+    (debug_msg "macroexpand_toplevel_list res xlist" xlist (the_callcount))
+    xlist
+    ))
+
+;;; expand an s-expression into a tuple of formal bindings
+(defun lambda_arg_bindings (formalsexp)
+;  (debug_msg "lambda_arg_bindings formalsexp" formalsexp (the_callcount))
+  ;; special case for null arglist
+  (if (null formalsexp)
+      (progn
+	(return (make_multiple discr_multiple 0))))
+  (assert_msg "check formalsexp" (is_a formalsexp class_sexpr))
+  (let ( (:long argrk 0)
+	 (argtype ctype_value)
+	 (arglist (unsafe_get_field :sexp_contents formalsexp))
+	 (argloc (unsafe_get_field :loca_location formalsexp))
+	 (argmap (make_mapobject discr_mapobjects (+i 4 (list_length arglist))))
+	 (bndlist (make_list discr_list)) 
+	 (curpair (list_first arglist))
+	 )
+    ;;; first loop on arg
+    (forever argloop
+	     (if (null curpair) (exit argloop))
+	     (assert_msg "check curpair" (is_pair curpair))
+	     (let ( (curarg (pair_head curpair)) )
+	       (cond
+		( (is_a curarg class_keyword)
+		  (let ( (cty (unsafe_get_field :symb_data curarg)) )
+		    (if (and (is_a cty class_ctype) 
+			     (== (unsafe_get_field :ctype_keyword cty) curarg))
+			(setq argtype cty)
+		      (progn
+			(error_strv argloc "invalid keyword in formal arglist"
+				    (unsafe_get_field :named_name curarg))    
+			)
+		      )))
+		( (is_a curarg class_symbol)
+		  (if (mapobject_get argmap curarg)
+		      (error_strv argloc "duplicate argument in formal arglist"
+				  (unsafe_get_field :named_name curarg)))
+		  (let ( (curbind
+			  (make_instance class_formal_binding 
+					 :binder curarg
+					 :fbind_type argtype)) )
+		    (put_int curbind argrk)
+		    (mapobject_put argmap curarg curbind)
+		    (list_append bndlist curbind)
+		    (setq argrk (+i argrk 1))
+		    )
+		  )
+		(:else 
+		 (debug_msg "unexpected argument in formal arglist" curarg (the_callcount))
+		 (let ( (discrarg  (discrim curarg) ))
+		   (error_strv argloc "unexepected argument in formal arglist" 
+			       (unsafe_get_field :named_name discrarg))
+		   )))
+	       (setq curpair (pair_tail curpair))))
+    ;;; second loop to fill the bindings tuple
+    (let ( (bndtup (make_multiple discr_multiple argrk)) 
+	   (:long ix 0)
+	   (bndpair (list_first bndlist))
+	   )
+      (forever bndloop
+	       (if (null bndpair) (exit bndloop))
+	       (assert_msg "check bndpair" (is_pair bndpair))
+	       (let ( (curbnd (pair_head bndpair)) )
+		 (assert_msg "check curbnd" (is_a curbnd class_formal_binding))
+		 (multiple_put_nth bndtup ix curbnd)
+		 )
+	       (setq ix (+i ix 1))
+	       (setq bndpair (pair_tail bndpair))
+	       )
+      bndtup
+      )))
+
+
+;;;;;;;;;;;;;;;; install an initial macro expanser
+(defun install_initial_macro (symb expander)
+  (assert_msg "check sexpr" (is_a symb class_symbol))
+  (assert_msg "check expander" (is_closure expander))
+  (let ( (mbind (make_instance class_macro_binding 
+			       :binder symb
+			       :mbind_expanser expander
+			       )) )
+	 (put_env initial_environment mbind)
+))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;; macro expansers
+;; the defprimitive expander
+(defun mexpand_defprimitive (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check env" (is_a env class_environment))
+;  (debug_msg "mexp.defprim sexpr" sexpr (the_callcount))
+  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
+	 (loc  (unsafe_get_field :loca_location sexpr))
+	 (curpair (pair_tail (list_first cont)))
+	 (symb (pair_head curpair))
+	 )
+    (or (is_a symb class_symbol)
+	(error_plain loc "missing symbol for defprimitive"))
+    (setq curpair (pair_tail curpair))
+    ;; parse the formal arguments
+    (let ( (btup (lambda_arg_bindings (pair_head curpair))) )
+      (setq curpair (pair_tail curpair))
+;      (debug_msg "btup after lambda_arg_bindings in mexpand_defprimitive" btup (the_callcount))
+      ;; parse the type keyword
+      (let ( (typkw  (pair_head curpair)) )
+	(or (is_a typkw class_keyword)
+	    (error_plain loc "missing type keyword for defprimitive"))
+	(let ( (cty (unsafe_get_field :symb_data typkw)) )
+	  (or (and (is_a cty class_ctype) 
+		   (== (unsafe_get_field :ctype_keyword cty) typkw))
+	      (progn
+		(error_strv loc "invalid type keyword for defprimitive"
+			    (unsafe_get_field :named_name typkw))    
+		))
+	  ;; parse the rest as to be expanded
+	  (setq curpair (pair_tail curpair))
+	  (let ( (:long nbcomp (pair_listlength curpair))
+		 (etuple (make_multiple discr_multiple nbcomp))
+		 (:long ix 0) )
+	    (forever comploop
+		     (or (is_pair curpair) (exit comploop))
+		     (let ( (curcomp  (macroexpand_1 (pair_head curpair) env mexpander)) )
+		       ;; change string to verbatimstring to ease primitive expansion
+		       ;; and check that each component is e string or a symbol
+		       (cond ( (== (discrim curcomp) discr_string)
+			       (setq curcomp (make_string discr_verbatimstring curcomp)))
+			     ( (!= (discrim curcomp) class_symbol)
+			       (error_strv loc "invalid expansion component in primitive"
+					   (unsafe_get_field :named_name symb))))
+		       (multiple_put_nth etuple ix curcomp)
+		       (setq curpair (pair_tail curpair))
+		       (setq ix (+i ix 1))))
+	    (let ( (sdefpri
+		    (make_instance class_src_defprimitive
+				   :src_loc loc
+				   :sdef_name symb
+				   :sformal_args btup
+				   :sprim_type cty
+				   :sprim_expansion etuple))
+		   (primit
+		    (make_instance class_primitive
+				   :named_name (unsafe_get_field :named_name symb)
+				   :prim_formals btup
+				   :prim_type cty
+				   :prim_expansion etuple))
+		   (pbind
+		    (make_instance class_primitive_binding
+				   :binder symb
+				   :pbind_primdef sdefpri
+				   :pbind_primitive primit
+				   ))
+		   )
+	      (put_env env pbind)
+	      sdefpri
+	      )))))))
+(install_initial_macro 'defprimitive mexpand_defprimitive)
+
+
+
+;;;;;;;;;;;;;;;;;; the defun expander
+(defun mexpand_defun (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check env" (is_a env class_environment))
+  (debug_msg "mexp.defun sexpr" sexpr (the_callcount))
+  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
+	 (loc  (unsafe_get_field :loca_location sexpr))
+	 (curpair (pair_tail (list_first cont)))
+	 (symb (pair_head curpair))
+	 (newenv (fresh_env env))
+	 )
+    (or (is_a symb class_symbol)
+	(error_plain loc "missing symbol for defun"))
+    (setq curpair (pair_tail curpair))
+    ;; parse the formal arguments
+    (or (null (pair_head curpair))
+	(is_a (pair_head curpair) class_sexpr)
+	(error_plain loc "missing or invalid arglist for defun"))
+    (let ( (btup (lambda_arg_bindings (pair_head curpair))) )
+;      (debug_msg "defun btup" btup (the_callcount))
+      (or (is_multiple btup)
+	  (error_plain loc "missing formal arguments for defun"))
+      (multiple_iterate btup (lambda (fb) (put_env newenv fb) btup) btup)
+      (setq curpair (pair_tail curpair))
+      (let ( (bodytup (expand_pairlist_as_tuple curpair newenv mexpander)) 
+	     (sdefun
+	      (make_instance class_src_defun
+			     :src_loc loc
+			     :sdef_name symb
+			     :sformal_args btup
+			     :sfun_body bodytup
+			     ))
+	     (fbind 
+	      (make_instance class_function_binding
+			     :binder symb
+			     :fubind_defun sdefun
+			     ))
+	     )
+	      (put_env env fbind)
+	      sdefun
+	))))
+(install_initial_macro 'defun mexpand_defun)
+
+
+
+;;;;;;;;;;;;;;;; the defclass expander
+
+;; internal routine with multiple results to scan the defclass
+(defun scan_defclass (sexpr env mexpander)
+  (let ( (predef ())
+	 (supernam ())
+	 (superbind ())
+	 (superclass ())
+	 (fieldnams ())
+	 (docstr ())
+	 (cont (unsafe_get_field :sexp_contents sexpr))
+	 (loc  (unsafe_get_field :loca_location sexpr))
+	 (fieldsloc ())
+	 (curpair (pair_tail (list_first cont)))
+	 (symb (pair_head curpair))
+	 )
+    (or (is_a symb class_symbol)
+	(error_plain loc "missing symbol for defclass"))
+    (debug_msg "scandefclass start cont" cont (the_callcount))
+    (debug_msg "scandefclass start curpair" curpair (the_callcount))
+    (setq curpair (pair_tail curpair))
+    (forever scanloop
+	     (debug_msg "scandefclass scanloop curpair" curpair (the_callcount))
+	     (if (not (is_pair curpair)) (exit scanloop))
+	     (let ( (curkw (pair_head curpair)) )
+	       (debug_msg "scandefclass scanloop curkw" curkw (the_callcount))
+	       (if (not (is_a curkw class_keyword)) 
+		   (error_plain loc "expecting keyword in defclass"))
+	       (setq curpair (pair_tail curpair))
+	       (let ( (curval (pair_head curpair)) )
+		 (setq curpair (pair_tail curpair))
+		 (debug_msg "scandefclass scanloop curval" curval (the_callcount))
+		 (cond ( (== curkw ':super)
+			 (if supernam (error_plain loc "duplicate super in defclass"))
+			 (if (not (is_a curval class_symbol))
+			     (error_plain loc "bad super in defclass"))
+			 (setq supernam curval)
+			 (let ( (superb (find_env env supernam)) )
+			   ;;; should handle the case when the class is bound in the start environment
+			   ;;; to a value which happens to be a class
+			   (cond ( (is_a superb class_class_binding)
+				   (setq superbind superb) 
+				   (setq superclass (unsafe_get_field :cbind_class superb))
+				   )
+				 ( (is_a superb class_value_binding)
+				   (let ((superval (unsafe_get_field :vbind_value superb)))
+				     (if (is_a superval class_class)
+					 (progn
+					   (setq superbind superb)
+					   (setq superclass superval))
+				       (error_strv loc "super is not a class in defclass" 
+						   (unsafe_get_field :named_name supernam)))))
+				 (:else 
+				  (error_strv loc "invalid super in defclass" 
+					      (unsafe_get_field :named_name supernam)))
+				 )
+			   ))
+		       ( (== curkw ':fields)
+			 (if fieldnams (error_plain loc "duplicate fields in defclass"))
+			 (if (not (is_a curval class_sexpr))
+			     (error_plain loc "bad fields in defclass"))
+			 (let ( (namlist (unsafe_get_field :sexp_contents curval))
+				(namloc (unsafe_get_field :loca_location curval))
+				(:long nbnam  (list_length namlist))
+				(:long ix 0)
+				(nampair (list_first namlist))
+				(namtupl (make_multiple discr_multiple nbnam)) )
+			   (setq fieldsloc namloc)
+			   (forever namloop
+				    (if (not (is_pair nampair)) (exit namloop))
+				    (let ( (curnam (pair_head nampair)) )
+				      (if (not (is_a curnam class_symbol))
+					  (error_plain namloc "non name field in defclass"))
+				      (multiple_put_nth namtupl ix curnam)
+				      )
+				    (setq nampair (pair_tail nampair))
+				    (setq ix (+i ix 1))
+				    )
+			   (setq fieldnams namtupl)
+			   ))
+		       ( (== curkw ':predef)
+			 (if predef (error_plain loc "duplicate predef in defclass"))
+			 (setq predef (macroexpand_1 curval env mexpander))
+			 (or (is_integerbox predef)
+			     (is_a predef class_symbol)
+			     (error_plain loc "bad predef in class"))
+			 )
+		       ( (== curkw ':docstr)
+			 (if docstr (error_plain loc "duplicate docstr in defclass"))
+			 (setq docstr (macroexpand_1 curval env mexpander))
+			 (or (is_string docstr)
+			     (error_plain loc "bad docstr in class"))
+			 )
+		       (:else
+			(error_strv loc "invalid keyword in defclass" 
+				    (unsafe_get_field :named_name curkw))
+			)
+		       ))))
+    (debug_msg "scandefclass symb" symb (the_callcount))
+    (debug_msg "scandefclass loc" loc (the_callcount))
+    (debug_msg "scandefclass supernam" supernam (the_callcount))
+    (debug_msg "scandefclass superbind" superbind (the_callcount))
+    (debug_msg "scandefclass superclass" superclass (the_callcount))
+    (debug_msg "scandefclass predef" predef (the_callcount))
+    (debug_msg "scandefclass fieldnams" fieldnams (the_callcount))
+    (debug_msg "scandefclass fieldsloc" fieldsloc (the_callcount))
+    (debug_msg "scandefclass docstr" docstr (the_callcount))
+    (return symb loc supernam superbind superclass predef fieldnams fieldsloc docstr)
+    ))
+
+
+(defun mexpand_defclass (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check env" (is_a env class_environment))
+  (debug_msg "mexp.defclass sexpr" sexpr (the_callcount))
+  (multicall 
+   (symb loc supernam superbind superclass predef fieldnams fieldsloc docstr)
+   (scan_defclass sexpr env mexpander)
+  (debug_msg "mexp.defclass symb" symb (the_callcount))
+  (debug_msg "mexp.defclass loc" loc (the_callcount))
+  (debug_msg "mexp.defclass supernam" supernam (the_callcount))
+  (debug_msg "mexp.defclass superbind" superbind (the_callcount))
+  (debug_msg "mexp.defclass superclass" superclass (the_callcount))
+  (debug_msg "mexp.defclass predef" predef (the_callcount))
+  (debug_msg "mexp.defclass fieldnams" fieldnams (the_callcount))
+  (debug_msg "mexp.defclass fieldsloc" fieldsloc (the_callcount))
+  (debug_msg "mexp.defclass docstr" docstr (the_callcount))
+   (let ( 
+	 (ancestors (if (is_object superclass)
+			(let ( (superancestors (unsafe_get_field :class_ancestors superclass))
+			       (:long nbsuperanc (multiple_length superancestors))
+			       (anctuple (make_multiple discr_seqclass (+i 1 nbsuperanc)))
+			       (:long ix 0)
+			       )
+			  (assert_msg "check superclass" (is_a superclass class_class))
+			  (assert_msg "check superancestors" (is_multiple superancestors))
+			  (forever ancloop
+				   (if (>=i ix nbsuperanc) (exit ancloop))
+				   (multiple_put_nth anctuple ix (multiple_nth superancestors ix))
+				   (setq ix (+i ix 1))
+				   )
+			  (multiple_put_nth anctuple nbsuperanc superclass)
+			  anctuple
+			  )
+		      (make_multiple discr_seqclass 0)))
+	 (superfields (if (is_object superclass)
+			  (unsafe_get_field :class_fields superclass)))
+	 (:long nbsuperfields (multiple_length superfields))
+	 (:long nbfieldnames (multiple_length fieldnams))
+	 (boxnbsuperfields (make_integerbox discr_integer nbsuperfields))
+	 (fieldstrmap (make_mapstring discr_mapstrings (+i 3 (*i 2 (+i nbsuperfields nbfieldnames)))))
+	 (fieldtup (make_multiple discr_seqfield (+i nbsuperfields nbfieldnames)))
+	 (ownfieldbindings (make_multiple discr_multiple nbfieldnames))
+	 (newclass (make_instance class_class
+				  :named_name (unsafe_get_field :named_name symb)
+				  :class_ancestors ancestors
+				  ;; other fields to be set later
+				  ))
+	 (clabind (make_instance class_class_binding
+				 :binder symb
+				 :cbind_class newclass))
+	 )
+     (put_env env clabind)
+     (debug_msg "expdefclas superfields" superfields (the_callcount))
+     (multiple_iterate 
+      superfields 
+      (lambda (sfld :long ix)
+	(messagenum_dbg "expdefclasupflds ix" ix)
+	(messageval_dbg "expdefclasupfldsval sfld" sfld)
+	(debug_msg "expdefclasupflds superfield" sfld (the_callcount))
+	(assert_msg "check superfield" (is_a sfld class_field))
+	(multiple_put_nth fieldtup ix sfld)
+	(mapstring_putstr fieldstrmap (unsafe_get_field :named_name sfld) sfld)
+	sfld
+	))
+     (multiple_iterate
+      fieldnams
+      (lambda (fldnam :long ix)
+	(messagenum_dbg "expdefclafldnam ix" ix)
+	(debug_msg "expdefclafldnam fldnam" fldnam (the_callcount))
+	(assert_msg "check fldnam" (is_a fldnam class_symbol))
+	(let ( (fldstr (unsafe_get_field :named_name fldnam)) 
+	       )
+	  (if (mapstring_getstr fieldstrmap fldstr)
+	      (error_strv fieldsloc "duplicate field in deflclass" fldstr))
+	  (let ( (:long fldoff (+i ix (get_int boxnbsuperfields))) 
+		 (newfld (make_instance class_field
+					:named_name fldstr
+					:fld_ownclass newclass
+					)) )
+	    (put_int newfld fldoff)
+	    (messagenum_dbg "expdefclafldnam fldoff" fldoff)
+	    (debug_msg "expdefclafldnam newfld" newfld (the_callcount))
+	    (multiple_put_nth fieldtup fldoff newfld)
+	    (mapstring_putstr fieldstrmap fldstr newfld)
+	    (let ( (newfldbind (make_instance class_field_binding
+					      :binder fldnam
+					      :flbind_clabind clabind
+					      :flbind_field newfld)) )
+	      (put_env env newfldbind)
+	      (multiple_put_nth ownfieldbindings ix newfldbind)
+	      )
+	    newfld
+	    ))))
+     (unsafe_put_fields newclass
+			:class_fields fieldtup)
+     (debug_msg "mexp.defclass newclass" newclass (the_callcount))
+     (make_instance class_src_defclass
+		    :src_loc loc
+		    :sdef_name symb
+		    :sobj_predef predef
+		    :sobj_docstr docstr
+		    :sclass_clabind clabind
+		    :sclass_superbind superbind
+		    :sclass_fldbinds ownfieldbindings
+		    ))))
+(install_initial_macro 'defclass mexpand_defclass)
+
+
+;;;;;;;;;;;;;;;; the definstance expander
+
+;; internal to parse a field assignment in a given class
+(defun parse_field_assignment (cla loc fldkw expr env mexpander)
+  (assert_msg "check cla" (is_a cla class_class))
+  (assert_msg "check fldkw" (is_a fldkw class_keyword))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check mexpander" (is_closure mexpander))
+  ;; expr is an sexpr or a symbol or a string or ...
+  (let ( (fldbox (make_box discr_box ())) )
+    ;; if we have a class, find the field inside
+    (if (is_a cla class_class)
+	(multiple_iterate 
+	 (unsafe_get_field :class_fields cla)
+	 (lambda (cfld :long ix)
+	   (assert_msg "check fld" (is_a cfld class_field))
+	   (if (==s (unsafe_get_field :named_name cfld) 
+		    (unsafe_get_field :named_name fldkw))
+	       (progn 
+		 (box_put fldbox cfld)
+		 ()			; nil to exit to iteration
+		 )
+	     cfld))
+	 )
+      ;; othewise, find the field by its bound name
+      (let ( (fldnam (create_symbolstr (unsafe_get_field :named_name fldkw))) 
+	     (fldbind (find_env env fldnam)) 
+	     (fld  (cond 
+		    ( (is_a fldbind class_field_binding)
+		      (unsafe_get_field :flbind_field fldbind) )
+		    ( (is_a fldbind class_value_binding)
+		      (let ( (vfld (unsafe_get_field :vbind_value fldbind)) )
+			(if (is_a vfld class_field)
+			    vfld)) )
+		    )) )
+	(if (is_a fld class_field)
+	    (box_put fldbox fld)
+	  (error_strv loc "invalid field name in field assignment" 
+		      (unsafe_get_field :named_name fldkw)))))
+    ;; at last make the field assignment
+    (let ( (fld (box_content fldbox)) )
+      (if (is_a fld class_field)
+	  (let ( (xex (macroexpand_1 expr env mexpander)) )
+	    (make_instance class_src_fieldassign 
+			   :src_loc loc
+			   :sfla_field fld
+			   :sfla_expr xex
+			   ))))))
+
+;; the definstance expanser
+(defun mexpand_definstance (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check env" (is_a env class_environment))
+  (debug_msg "mexp.definstance sexpr" sexpr (the_callcount))
+  (let ( (predef ())
+	 (objnum ())
+	 (fields ())
+	 (fieldnams ())
+	 (cont (unsafe_get_field :sexp_contents sexpr))
+	 (loc  (unsafe_get_field :loca_location sexpr))
+	 (curpair (pair_tail (list_first cont)))
+	 (symb (pair_head curpair))
+	 (claname ())
+	 (cla ())
+	 (clabind ())
+	 )
+    (or (is_a symb class_symbol)
+	(error_plain loc "missing symbol for definstance"))
+    (debug_msg "mexpand_definstance sexpr" sexpr (the_callcount))
+    (setq curpair (pair_tail curpair))
+    (let ( (nam (pair_head curpair)) )
+      (or (is_a nam class_symbol)
+	  (error_plain loc "missing class name for definstance"))
+      (let ( (bnd (find_env env nam)) 
+	     (fldlist (make_list discr_list))
+	     )
+	(cond 
+	 ( (is_a bnd class_class_binding)
+	   (setq clabind bnd)
+	   (setq cla (unsafe_get_field :cbind_class bnd)) )
+	 ( (and (is_a bnd class_value_binding)
+		(is_a (unsafe_get_field :vbind_value bnd) class_class))
+	   (setq clabind bnd)
+	   (setq cla (unsafe_get_field :vbind_value bnd)))
+	 (:else
+	  (error_strv loc "invalid class name for definstance"
+		      (unsafe_get_field :named_name nam))
+	  (return)
+	  ))
+	(setq claname nam)
+	(assert_msg "check cla" (is_a cla class_class))
+	(setq curpair (pair_tail curpair))
+	(forever insloop
+		 (debug_msg "mexpand_definstance insloop curpair" curpair (the_callcount))
+		 (or (is_pair curpair) (exit insloop))
+		 (let ( (curfkw (pair_head curpair)) )
+		   (debug_msg "mexpand_definstance insloop curfkw" curfkw (the_callcount))
+		   (or (is_a curfkw class_keyword)
+		       (error_plain loc "expecting keyword in definstance"))
+		   (setq curpair (pair_tail curpair))
+		   (let ( (curexp (pair_head curpair)) )
+		     (cond  ( (== curfkw ':obj_num)
+			      (if curexp (error_plain loc "duplicate :obj_num in definstance"))
+			      (setq objnum 
+				    (if (is_a curexp class_sexpr)
+					(macroexpand_1 curexp env mexpander)
+				      curexp))
+			      )
+			    ( (== curfkw ':predef)
+			      (if curexp (error_plain loc "duplicate :predef in definstance"))
+			      (setq predef 
+				    (if (is_a curexp class_sexpr)
+					(macroexpand_1 curexp env mexpander)
+				      curexp))
+			      )
+			    (:else 
+			     (let  ( (flda (parse_field_assignment cla loc curfkw curexp env mexpander)) )
+			       (if flda 
+				   (list_append fldlist flda)
+				 )))))
+		   (setq curpair (pair_tail curpair))
+		   ))
+	(let ( ( fastup (list_to_multiple fldlist discr_multiple)) )
+	  (make_instance class_src_definstance
+			 :src_loc loc
+			 :sdef_name symb
+			 :sobj_predef predef
+			 :sinst_class cla
+			 :sinst_clabind clabind
+			 :sinst_objnum objnum
+			 :sinst_fields fastup
+			 ))))))
+(install_initial_macro 'definstance mexpand_definstance)
+
+
+
+;;;; the make_instance expander
+(defun mexpand_make_instance (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check env" (is_a env class_environment))
+  (let ( (fields ())
+	 (fieldnams ())
+	 (cont (unsafe_get_field :sexp_contents sexpr))
+	 (loc  (unsafe_get_field :loca_location sexpr))
+	 (curpair (pair_tail (list_first cont)))
+	 (claname (pair_head curpair))
+	 (cla ())
+	 (clabind ())
+	 )
+    (debug_msg "mexpand_make_instance start sexpr" sexpr (the_callcount))
+    (or (is_a claname class_symbol)
+	(error_plain loc "missing class symbol for make_instance"))
+    (let ( (bnd (find_env env claname)) 
+	   (fldlist (make_list discr_list))
+	   )
+      (cond 
+       ( (is_a bnd class_class_binding)
+	 (setq clabind bnd)
+	 (setq cla (unsafe_get_field :cbind_class bnd)) )
+       ( (and (is_a bnd class_value_binding)
+	      (is_a (unsafe_get_field :vbind_value bnd) class_class))
+	 (setq clabind bnd)
+	 (setq cla (unsafe_get_field :vbind_value bnd)))
+       (:else
+	(error_strv loc "invalid class name for make_instance"
+		    (unsafe_get_field :named_name claname))
+	(return)
+	))
+      (assert_msg "check cla" (is_a cla class_class))
+      (setq curpair (pair_tail curpair))
+      (forever insloop
+	       (debug_msg "mexpand_make_instance insloop curpair" curpair (the_callcount))
+	       (or (is_pair curpair) (exit insloop))
+	       (let ( (curfkw (pair_head curpair)) )
+		 (or (is_a curfkw class_keyword)
+		     (error_plain loc "expecting keyword in make_instance"))
+		 (setq curpair (pair_tail curpair))
+		 (let ( (curexp (pair_head curpair)) )
+		   (let  ( (flda (parse_field_assignment cla loc curfkw curexp env mexpander)) )
+		     (if flda 
+			 (list_append fldlist flda)
+		       ))))
+	       (setq curpair (pair_tail curpair))
+	       )
+      (let ( ( fastup (list_to_multiple fldlist discr_multiple)) )
+	(make_instance class_src_make_instance
+		       :src_loc loc
+		       :smins_class cla
+		       :smins_clabind clabind
+		       :smins_fields fastup)
+	))))
+(install_initial_macro 'make_instance mexpand_make_instance)
+
+
+
+;;;; the unsafe_put_fields expander
+(defun mexpand_unsafe_put_fields (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check env" (is_a env class_environment))
+  (let ( (fields ())
+	 (fieldnams ())
+	 (cont (unsafe_get_field :sexp_contents sexpr))
+	 (loc  (unsafe_get_field :loca_location sexpr))
+	 (curpair (pair_tail (list_first cont)))
+	 (objsrc (pair_head curpair))
+	 (objexp 
+	  (if (is_a objsrc class_sexpr)
+	      (macroexpand_1 objsrc env mexpander)
+	    objsrc))
+	 )
+    (setq curpair (pair_tail curpair))
+    (let ( (fldlist (make_list discr_list))
+	   )
+      (forever insloop
+	       (or (is_pair curpair) (exit insloop))
+	       (let ( (curfkw (pair_head curpair)) )
+		 (or (is_a curfkw class_keyword)
+		     (error_plain loc "expecting heyword in unsafe_put_fields"))
+		 (setq curpair (pair_tail curpair))
+		 (let ( (curexp (pair_head curpair)) )
+		   (let  ( (flda (parse_field_assignment () loc curfkw curexp env mexpander)) )
+		     (if flda 
+			 (list_append fldlist flda)
+		       ))))
+	       (setq curpair (pair_tail curpair))
+	       )
+      (let ( ( fastup (list_to_multiple fldlist discr_multiple)) )
+	(make_instance class_src_unsafe_put_fields
+		       :src_loc loc
+		       :suput_obj objexp
+		       :suput_fields fastup)
+	))))
+(install_initial_macro 'unsafe_put_fields mexpand_unsafe_put_fields)
+
+;;;; the unsafe_get_field expander
+(defun mexpand_unsafe_get_field (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check env" (is_a env class_environment))
+  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
+	 (loc  (unsafe_get_field :loca_location sexpr))
+	 (curpair (pair_tail (list_first cont)))
+	 (curfkw (pair_head curpair)) 
+	 )
+    (or (is_a curfkw class_keyword)
+	(progn
+	  (error_plain loc "field keyword expected in unsafe_get_field")
+	  (return)))
+    (setq curpair (pair_tail curpair))
+    (let ( (curexp (pair_head curpair)) )
+      (setq curpair (pair_tail curpair))
+      (if curpair (error_plain loc "unsafe_get_field with more than two sons"))
+      ;; it is not a field assignment but we use the parse_field_assignment
+      ;; routine to get the field and the expression
+      (let  ( (flda (parse_field_assignment () loc curfkw curexp env mexpander)) )
+	(if (not (is_a flda class_src_fieldassign))
+	    (progn 
+	      (error_plain loc "bad field and expression in unsafe_get_field")
+	      (return)))
+	(let ( (fld (unsafe_get_field :sfla_field flda))
+	       (exp (unsafe_get_field :sfla_expr flda)) )
+	  (make_instance class_src_unsafe_get_field
+			 :src_loc loc
+			 :suget_obj exp
+			 :suget_field fld
+	  ))))))
+(install_initial_macro 'unsafe_get_field mexpand_unsafe_get_field)
+
+
+
+;;;; the setq expander
+(defun mexpand_setq (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check env" (is_a env class_environment))
+  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
+	 (loc  (unsafe_get_field :loca_location sexpr))
+	 (curpair (pair_tail (list_first cont)))
+	 (cursym (pair_head curpair)) 
+	 )
+    (or (is_a cursym class_symbol)
+	(progn
+	  (error_plain loc "var symbol name expected in setq")
+	  (return)))
+    (setq curpair (pair_tail curpair))
+    (let ( (curexp (pair_head curpair)) )
+      (setq curpair (pair_tail curpair))
+      (if curpair (error_plain loc "setq with more than two sons"))
+      (make_instance class_src_setq 
+		     :src_loc loc
+		     :sstq_var cursym
+		     :sstq_expr  (macroexpand_1 curexp env mexpander)
+		     )
+)))
+(install_initial_macro 'setq mexpand_setq)
+
+;;;;; the if expanser
+(defun mexpand_if (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check env" (is_a env class_environment))
+  (let ( (xcond ())
+	 (xthen ())
+	 (xelse ()) 
+	 (cont (unsafe_get_field :sexp_contents sexpr))
+	 (loc  (unsafe_get_field :loca_location sexpr))
+	 (curpair (pair_tail (list_first cont)))
+	 (curif (pair_head curpair)) )
+    (or (is_pair curpair) 
+	(error_plain loc "missing condition in IF"))
+    (setq curpair (pair_tail curpair))
+    (or (is_pair curpair) 
+	(error_plain loc "missing then in IF"))
+    (setq xcond (macroexpand_1 curif env mexpander))
+    (let ( (curthen (pair_head curpair)) )
+      (setq curpair (pair_tail curpair))
+      (setq xthen (macroexpand_1 curthen env mexpander))
+      (if (is_pair curpair)
+	  (let ( (curelse (pair_head curpair)) )
+	    (setq xelse (macroexpand_1 curelse env mexpander))
+	    (setq curpair (pair_tail curpair))
+	    (if (is_pair curpair)
+		(error_plain loc "IF with more than three sons"))))
+      (make_instance class_src_if
+		     :src_loc loc
+		     :sif_test xcond
+		     :sif_then xthen
+		     :sif_else xelse)
+      )))
+(install_initial_macro 'if mexpand_if)
+
+
+;;;;; the cond expanser
+(defun mexpand_cond (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check env" (is_a env class_environment))
+  (let (
+	(cont (unsafe_get_field :sexp_contents sexpr))
+	(loc  (unsafe_get_field :loca_location sexpr))
+	(cexptuple (pairlist_to_multiple 
+		    (pair_tail (list_first cont))
+		    discr_multiple
+		    (lambda (c)
+		      (or (is_a c class_sexpr)
+			  (error_plain loc "COND with non-sexpr"))
+		      c
+		      ))) 
+	(:long nbcond (multiple_length cexptuple))
+	(lastcexp (multiple_nth cexptuple (-i nbcond 1)))
+	(lastcontpair (if (is_a lastcexp class_sexpr)
+			  (list_first 
+			   (unsafe_get_field :sexp_contents lastcexp))))
+	(lastloc (if (is_a lastcexp class_sexpr)
+		     (unsafe_get_field :loca_location lastcexp)))
+	(lasttest (pair_head lastcontpair))
+	(res (cond 
+	      ( (== lasttest ':else) 
+		(pairlist_to_progn (pair_tail lastcontpair)
+				   lastloc
+				   env
+				   mexpander) )
+	      ( lasttest
+		(make_instance class_src_if
+			       :src_loc lastloc
+			       :sif_test (macroexpand_1 lasttest env mexpander)
+			       :sif_then (pairlist_to_progn (pair_tail lastcontpair)
+							    lastloc
+							    env
+							    mexpander)) 
+		)))
+	(:long ix (-i nbcond 2))
+	)
+    (forever revloop
+	     (if (<i ix 0) (exit revloop))
+	     (let ( (curcexp (multiple_nth cexptuple ix)) )
+	       (if (is_a curcexp class_sexpr) 
+		   (let ( (curcloc (unsafe_get_field :loca_location curcexp))
+			  (curcfirstpair (list_first (unsafe_get_field :sexp_contents curcexp))) 
+			  )
+		     (if (<i (pair_listlength curcfirstpair) 2)
+			 (error_plain curcloc "COND element should have at least two components")
+		       (setq res
+			     (make_instance class_src_if
+					    :src_loc curcloc
+					    :sif_test  (macroexpand_1 (pair_head curcfirstpair)
+								      env
+								      mexpander)
+					    :sif_then  (pairlist_to_progn (pair_tail curcfirstpair)
+									  curcloc
+									  env
+									  mexpander)
+					    :sif_else res)))
+	     )))
+	     (setq ix (-i ix 1))
+	     )
+    res
+    ))
+(install_initial_macro 'cond mexpand_cond)
+
+
+;;;; the and expanser
+;;; AND pseudo syntax
+;;; (AND a1) is expanded into a1
+;;; (AND a1 a2) is expansed into (IF a1 a2)
+;;; (AND a1 a2 a3) is expansed into (IF a1 (IF a2 a3))
+(defun mexpand_and (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check env" (is_a env class_environment))
+  (let (
+	(cont (unsafe_get_field :sexp_contents sexpr))
+	(loc  (unsafe_get_field :loca_location sexpr))
+	(curpair (pair_tail (list_first cont)))
+	(cxtup (pairlist_to_multiple 
+		curpair
+		discr_multiple
+		(lambda (c) (macroexpand_1 c env mexpander)
+		  )))
+	(:long nbcomp (multiple_length cxtup))
+	)
+    (debug_msg "mexpand_and sexpr:" sexpr (the_callcount))
+    (debug_msg "mexpand_and curpair:" curpair (the_callcount))
+    (debug_msg "mexpand_and cxtup:" cxtup (the_callcount))
+    (if (<i nbcomp 1)
+	(error_plain loc "AND without sons")
+      (let ( (res (multiple_nth cxtup (-i nbcomp 1)))
+	     (:long ix (-i nbcomp 2)) )
+	(forever revloop
+		 (if (<i ix 0) (exit revloop))
+		 (let ( (curc (multiple_nth cxtup ix)) )
+		   (messagenum_dbg "mexpand_and ix" ix)
+		   (debug_msg "mexpand_and curc:" curc (the_callcount))
+		   (setq res 
+			 (make_instance class_src_if
+					:src_loc loc
+					:sif_test curc
+					:sif_then res))
+		   )
+		 (debug_msg "mexpand_and res:" res (the_callcount))
+		 (setq ix (-i ix 1))
+		 )
+	res))))
+(install_initial_macro 'and mexpand_and)
+      
+;;;; the or expanser
+(defun mexpand_or (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check env" (is_a env class_environment))
+  (let (
+	(cont (unsafe_get_field :sexp_contents sexpr))
+	(loc  (unsafe_get_field :loca_location sexpr))
+	(cxtup (pairlist_to_multiple 
+		(pair_tail (list_first cont))
+		discr_multiple
+		(lambda (c) (macroexpand_1 c env mexpander)
+		  )))
+	(:long nbcomp (multiple_length cxtup))
+	)
+    (if (<i nbcomp 1)
+	(error_plain loc "OR without sons")
+      (make_instance class_src_or
+		     :src_loc loc
+		     :sor_disj cxtup)
+)))
+(install_initial_macro 'or mexpand_or)
+
+;;;;;;;; for LET
+;; internal routine to make a letbinding
+(defun mexpand_letbinding (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check env" (is_a env class_environment))
+  (let (
+	(cont (unsafe_get_field :sexp_contents sexpr))
+	(loc  (unsafe_get_field :loca_location sexpr))
+	(ctyp ctype_value)
+	(var ())
+	(expr ())
+	(curpair (list_first cont))
+	(curarg ())
+	)
+    (setq curarg (pair_head curpair))
+    (if (is_a curarg class_keyword)
+	(let ( (cty (unsafe_get_field :symb_data curarg)) )
+	  (if (and (is_a cty class_ctype) 
+		   (== (unsafe_get_field :ctype_keyword cty) curarg))
+	      (setq ctyp cty)
+	    (error_strv loc "letbinding with invalid type keyword"
+			(unsafe_get_field :named_name curarg)))
+	  (setq curpair (pair_tail curpair))
+	  (setq curarg (pair_head curpair))
+	  ))
+    (cond ( (is_a curarg class_keyword)
+	    (error_strv loc "letbinding cannot bind keyword"  
+			(unsafe_get_field :named_name curarg)))
+	  ( (is_a curarg class_symbol)
+	    (setq var curarg)
+	    (setq curpair (pair_tail curpair))
+	    (setq curarg (pair_head curpair))))
+    (or var (error_plain loc "missing variable in letbinding"))
+    (if curarg
+	(progn 
+	  (setq expr (macroexpand_1 curarg env mexpander))
+	  (setq curpair (pair_tail curpair))
+	  (setq curarg (pair_head curpair))
+	  (if curarg (error_plain loc "too long letbinding"))))
+    (make_instance class_src_letbinding
+		   :src_loc loc
+		   :sletb_type ctyp
+		   :sletb_binder var
+		   :sletb_expr expr)
+    ))
+
+;;; the LET expander itself
+(defun mexpand_let (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check env" (is_a env class_environment))
+  (let (
+	(cont (unsafe_get_field :sexp_contents sexpr))
+	(loc  (unsafe_get_field :loca_location sexpr))
+	(secpair (pair_tail (list_first cont)))
+	(restpair (pair_tail secpair))
+	(bindexpr (pair_head secpair))
+	(newenv (fresh_env env))
+	(bindtup ())
+	(bodytup ())
+	)
+    (if bindexpr 
+	(if (is_a bindexpr class_sexpr) 
+	    (setq bindtup 
+		  (pairlist_to_multiple 
+		   (list_first (unsafe_get_field :sexp_contents bindexpr))
+		   discr_multiple
+		   (lambda (b) (mexpand_letbinding b env mexpander))))
+	  (error_plain loc "missing letbinding-s in LET"))
+      )
+    (multiple_iterate
+     bindtup
+     (lambda (slb)
+       (debug_msg "mexp.let. slb" slb (the_callcount))
+       (assert_msg "mexp.let. check slb" (is_a slb class_src_letbinding))
+       (let ( (lb (make_instance class_let_binding
+				:binder (unsafe_get_field :sletb_binder slb)
+				:letbind_type (unsafe_get_field :sletb_type slb)
+				:letbind_expr (unsafe_get_field :sletb_expr slb))) )
+	 (put_env newenv lb)
+	 slb
+       )))
+    (setq bodytup (pairlist_to_multiple restpair discr_multiple 
+					(lambda (e) (macroexpand_1 e newenv mexpander))))
+    (make_instance class_src_let
+		   :src_loc loc
+		   :slet_bindings bindtup
+		   :slet_body bodytup
+    )))
+(install_initial_macro 'let mexpand_let)
+
+
+;;;;;;;; for LAMBDA
+(defun mexpand_lambda (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check env" (is_a env class_environment))
+  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
+	 (loc  (unsafe_get_field :loca_location sexpr))
+	 (curpair (pair_tail (list_first cont))) 
+	 (newenv (fresh_env env))
+	 )
+    ;; parse the formal arguments
+    (let ( (argtup (lambda_arg_bindings (pair_head curpair))) )
+      (debug_msg "argtup after lambda_arg_bindings in mexpand_lambda" argtup (the_callcount))
+      (setq curpair (pair_tail curpair))
+      (multiple_iterate argtup 
+			(lambda (lb)
+			  (put_env newenv lb)
+			  argtup
+			  ))
+      (let ( (bodytup (pairlist_to_multiple curpair discr_multiple 
+					    (lambda (e) (macroexpand_1 e newenv mexpander)))) )
+	(make_instance class_src_lambda
+		       :src_loc loc
+		       :slam_argbind argtup
+		       :slam_body bodytup)))))
+(install_initial_macro 'lambda mexpand_lambda)
+      
+
+;;;;;;;; for QUOTE (only of symbols or keywords)
+(defun mexpand_quote (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (assert_msg "check env" (is_a env class_environment))
+  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
+	 (loc  (unsafe_get_field :loca_location sexpr))
+	 (curpair (pair_tail (list_first cont))) 
+	 (quoted (pair_head curpair))
+	 )
+    (if (pair_tail curpair)
+	(error_plain loc "QUOTE should have only one symbol argument"))
+    (if (not (is_a quoted class_symbol))
+	(error_plain loc "QUOTE should have a symbol argument - composite quotations unsupported"))
+    (debug_msg "mexpand_quote quoted" quoted)
+    (if (is_a quoted class_keyword)
+	(return quoted))
+    (let ( (squ (make_instance class_src_quote
+			       :src_loc loc
+			       :squoted quoted)) )
+      (debug_msg "mexpand_quote squ" squ)
+      squ
+      )))
+(install_initial_macro 'quote mexpand_quote)
+
+;;;;;;;; for PROGN
+;; internal routine to make a progn from a pairlist at a location
+(defun pairlist_to_progn (pair loc env mexpander)
+  (assert_msg "check env" (is_a env class_environment))
+  (let ( (bodytup (pairlist_to_multiple 
+		   pair 
+		   discr_multiple
+		   (lambda (e) (macroexpand_1 e env mexpander)))) )
+    (make_instance class_src_progn
+		   :src_loc loc
+		   :sprogn_body bodytup
+		   )
+))
+
+;; internal routine to make a return from a pairlist at a location
+(defun pairlist_to_return (pair loc env mexpander)
+  (assert_msg "check env" (is_a env class_environment))
+  (let ( (bodytup (pairlist_to_multiple 
+		   pair 
+		   discr_multiple
+		   (lambda (e) (macroexpand_1 e env mexpander)))) )
+    (make_instance class_src_return
+		   :src_loc loc
+		   :sreturn_body bodytup
+		   )
+))
+
+;;;; the progn expanser
+(defun mexpand_progn (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (pairlist_to_progn (pair_head (unsafe_get_field :sexp_contents sexpr))
+		     (unsafe_get_field :loca_location sexpr)
+		     env
+		     mexpander)
+)
+(install_initial_macro 'progn mexpand_progn)
+
+;;;; the return expanser
+(defun mexpand_return (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (pairlist_to_return (pair_head (unsafe_get_field :sexp_contents sexpr))
+		     (unsafe_get_field :loca_location sexpr)
+		     env
+		     mexpander)
+)
+(install_initial_macro 'return mexpand_return)
+
+;;;; the forever expanser
+(defun mexpand_forever (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
+	 (loc  (unsafe_get_field :loca_location sexpr))
+	 (curpair (pair_tail (list_first cont))) 
+	 (labnam (pair_head curpair))
+	 (newenv (fresh_env env))
+	 )
+    (or (is_a labnam class_symbol)
+	(progn
+	  (error_plain loc "missing label in FOREVER")
+	  (return)))
+    (setq curpair (pair_tail curpair))
+    (let ( (labind (make_instance class_label_binding
+				  :binder labnam
+				  :labind_loc loc)) )
+      (put_env newenv labind)
+      (let ( (bodytup (pairlist_to_multiple
+		       curpair
+		       discr_multiple
+		       (lambda (e) (macroexpand_1 e newenv mexpander)))) )
+	(make_instance class_src_forever
+		       :src_loc loc
+		       :slabel_bind labind
+		       :sfrv_body bodytup)
+))))
+(install_initial_macro 'forever mexpand_forever)
+
+
+;;;; the exit expanser
+(defun mexpand_exit (sexpr env mexpander)
+  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
+  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
+	 (loc  (unsafe_get_field :loca_location sexpr))
+	 (curpair (pair_tail (list_first cont))) 
+	 (labnam (pair_head curpair))
+	 (newenv (fresh_env env))
+	 )
+    (or (is_a labnam class_symbol)
+	(progn
+	  (error_plain loc "missing label in EXIT")
+	  (return)))
+    (setq curpair (pair_tail curpair))
+    (let ( (labind (find_env env labnam)) )
+	   (or (is_a labind class_label_binding)
+	       (progn 
+		 (error_strv loc "bad label in EXIT" 
+			     (unsafe_get_field :named_name labnam))
+		 (return)))
+      (let ( (bodytup (pairlist_to_multiple
+		       curpair
+		       discr_multiple
+		       (lambda (e) (macroexpand_1 e newenv mexpander)))) )
+	(make_instance class_src_exit
+		       :src_loc loc
+		       :slabel_bind labind
+		       :sexi_body bodytup)
+))))
+(install_initial_macro 'exit mexpand_exit)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; normalized representations
+;; basically, the normalized representation of (f a (g x)) 
+;; is let y=(g x) in (f a y)
+;; etc... where y is a cloned symbol
+
+(defclass class_nrep
+  :super class_root
+  :fields (nrep_loc			;location in source
+))
+
+;; a simple stuff is a non-object, a symbol (or keyword or clonedsym),
+;; ...
+
+;; normal applications have simple functions & arguments
+(defclass class_nrep_apply
+  :super class_nrep
+  :fields (napp_fun			;simple function to apply
+	   napp_args			;tuple of simple arguments
+))
+;; normal chunk is a normalized expansion of primitive
+(defclass class_nrep_chunk
+  :super class_nrep
+  :fields (nchunk_expansion		;the expansion
+	   nchunk_primitive		;the primitive
+))
+
+;; normal lets have simple binding & body subexpressions
+(defclass class_nrep_let
+  :super class_nrep
+  :fields (nlet_bindings		;a tuple of class_normlet_binding-s
+	   nlet_body
+))
+
+;; normal return have a main & supplementary subexpressions
+(defclass class_nrep_return
+  :super class_nrep
+  :fields (nret_main			;main normal expression to return
+	   nret_rest			;tuple of normal expr...
+))
+
+;; normal if have simple test, then, else clauses & a ctype
+(defclass class_nrep_if
+  :super class_nrep
+  :fields (nif_test
+	   nif_then
+	   nif_else
+	   nif_ctyp
+))
+
+;; normal progn has a distingished last
+(defclass class_nrep_progn
+  :super class_nrep
+  :fields (nprogn_seq			;tuple of all but last
+	   nprogn_last
+	   ))
+
+;; normalized unsafe get field
+(defclass class_nrep_unsafe_get_field
+  :super class_nrep
+  :fields (nuget_obj
+	   nuget_field))
+
+
+;; normalized unsafe_put_field
+(defclass class_nrep_unsafe_put_fields
+  :super class_nrep
+  :fields (nuput_obj
+	   nuput_fields))
+
+;; normalized setq
+(defclass class_nrep_setq
+  :super class_nrep
+  :fields (nstq_var
+	   nstq_exp
+))
+
+;; normalized forever
+(defclass class_nrep_forever
+  :super class_nrep
+  :fields (nforever_bind 		;the label binding
+	   nforever_body		;a tuple
+	   nforever_result		;cloned symbol for result
+))
+
+;; normalized exit
+(defclass class_nrep_exit
+  :super class_nrep
+  :fields (nexit_bind			;the label binding
+	   nexit_val			;the exited value
+))
+
+;; normalized field assign (in make instance)
+(defclass class_nrep_fieldassign
+  :super class_nrep
+  :fields (nfla_field			;the field
+	   nfla_val			;its normalized value
+))
+
+;; normalized make instance
+(defclass class_nrep_make_instance
+  :super class_nrep
+  :fields (nmins_class			;the instanciated class
+	   nmins_cladata		;its data
+	   nmins_fields			;the tuple of field assignments
+))
+
+(defclass class_nrep_lambda 
+  :super class_nrep
+  :fields (nlambda_proc			;the procedure
+	   nlambda_constrout		;the constant routine
+	   nlambda_closedv		;the tuple of closed normal values
+))
+
+;;; procedures
+(defclass class_nrep_anyproc
+  :super class_nrep
+  :fields (
+	   nproc_body
+))
+
+
+;; the class of the initial procedure
+(defclass class_nrep_initproc
+  :super class_nrep_anyproc
+  :fields (ninit_topl			;list of toplevel nrep
+))
+
+;; normal routine procedure
+(defclass class_nrep_routproc
+  :super class_nrep_anyproc
+  :fields (
+	   nrpro_name			;name (if any)
+	   nrpro_argb			;argument bindings
+	   nrpro_closedb		;list of closed bindings
+	   nrpro_const			;list of constants
+	   nrpro_datarout		;routine data object
+	   nrpro_dataclos		;closure data object
+	   nrpro_thunklist		;list of thunks to be called when compiling it
+))
+
+
+;;; static normalized predef
+(defclass class_nrep_predef
+  :super class_nrep
+  :fields (
+	   nrpredef			;the predef is a symbol or a boxed integer
+))
+
+;;;; static data is build at module initialization time
+(defclass class_nrep_data
+  ;; the objnum is the predefined rank if any
+  :super class_nrep
+  :fields (ndata_name			;name if any of the data
+	   ndata_discrx		;discriminant normal expression 
+	   ndata_rank			;boxed integer rank of the data 
+	   ;;; we box the integer and don't use the objnum bzcause we
+	   ;;; might have a lot (>30000) of data
+	   ndata_locbind		;local binding tuple to fill the data
+	   ))
+
+;; normal "static" instance - built at modules initialization
+(defclass class_nrep_datainstance
+  :super class_nrep_data
+  :fields (ninst_objnum			;object number (a number or a symbol)
+	   ninst_predef			;predefined rank (number or symbol)
+	   ninst_hash			;integer hash
+	   ninst_slots			;tuple of normalized slots expressions
+))
+
+;; normal "static" string
+(defclass class_nrep_datastring
+  :super class_nrep_data
+  :fields ( nstr_string		    ;the string
+))
+
+;; normal "static" tuple
+(defclass class_nrep_datatuple
+  :super class_nrep_data
+  :fields ( ntup_comp			;the tuple of component values expressions
+))
+
+;; normal interned static symbol
+(defclass class_nrep_datasymbol
+  :super class_nrep_datainstance
+  :fields ( ndsy_namestr
+))
+
+;; normal interned static keyword
+(defclass class_nrep_datakeyword
+  :super class_nrep_datasymbol
+  :fields ( 
+))
+
+;; normal static routine data
+(defclass class_nrep_dataroutine
+  :super class_nrep_data
+  :fields (ndrou_proc		    ;associated procedure
+))
+
+;; normal static closure data
+(defclass class_nrep_dataclosure
+  :super class_nrep_data
+  :fields (ndclo_proc		    ;associated procedure
+	   ndclo_closv		    ;tuple of closed values
+))
+
+;; normal static start value
+;; obtained from an initial binding
+(defclass class_nrep_startval
+  :super class_nrep
+  :fields (nstart_var		    ;the variable
+	   ))
+
+;; normal  occurrence of a symbol 
+(defclass class_nrep_symocc
+  :super class_nrep
+  :fields (nocc_symb
+	   nocc_ctyp			;the ctype of the symbol, eg ctype_value
+	   nocc_bind			;the binding of the symbol
+))
+
+;; normal local occurrence of a symbol
+(defclass class_nrep_locsymocc
+  :super class_nrep_symocc
+  :fields (
+))
+
+;; normal closed occurrence of a symbol
+(defclass class_nrep_closedocc
+  :super class_nrep_symocc
+  :fields (ncloc_procs			;list of enclosing procedures
+))
+
+;; normal constant occurrence of a symbol
+(defclass class_nrep_constocc
+  :super class_nrep_closedocc
+)
+
+;; normal constant (.e.g a quoted symbol, a keyword, ...)
+(defclass class_nrep_constant
+  :super class_nrep
+  :fields (nconst_sval			;source value
+	   nconst_data			;normalized data
+	   nconst_proc			;containing proc
+))
+
+;; data field accessor (mostly used for defclass initialization) this
+;; translates into basilys_field_object(<obj>,<off>) of obj is not a
+;; datainstance and directly to the field if it is a datainstance
+(defclass class_nrep_fieldacc
+  :super class_nrep
+  :fields (naccf_obj			;data for the object to be accessed 
+	   naccf_fld			;rank or field to be accessoed
+))
+
+;;; data multiple accessor (mostly used for defclass initialization)
+;; this translates into basilys_multiple_nth(<mul>,<ix>) if mul is not
+;; a datatuple and directly to the component if it is a datatuple
+(defclass class_nrep_multacc
+  :super class_nrep
+  :fields (naccm_mul			;data for the multiple to be accessed
+	   naccm_ix			;index to be accessed (a boxed integer)
+))
+
+
+;;; normalization context
+(defclass class_normcontext
+  :super class_root
+  :fields (nctx_initproc		;initial procedure
+	   nctx_proclist		;list of procedures
+	   nctx_datalist		;list of data
+	   nctx_symbmap			;stringmap of name to interned symbols
+	   nctx_keywmap			;stringmap of name to interned keywords
+	   nctx_symbcachemap		;objmap of cached symbol -> occurrence
+	   nctx_predefmap		;objmap of predef -> boxedrank or symbols
+	   nctx_valmap			;objmap of values -> data 
+	   nctx_valbindmap 		;objmap of value binding -> data
+	   nctx_curproc			;current procedure
+))
+
+;;; add some data to a normalization context and return it
+(defun add_nctx_data (nctx ndata)
+  (assert_msg "check nctx" (is_a nctx class_normcontext))
+;  (debug_msg "add_nctx_data initial ndata" ndata (the_callcount))
+;  (shortbacktrace_dbg "add_nctx_data" 12)
+  (if (not (is_a ndata class_nrep_data))
+      (debug_msg "add_nctx_data bad ndata" ndata (the_callcount)))
+  (assert_msg "check ndata" (is_a ndata class_nrep_data))
+  (if (unsafe_get_field :ndata_rank ndata)
+      (debug_msg "add_nctx_data unfresh ndata" ndata (the_callcount)))
+  (assert_msg "fresh ndata" (null (unsafe_get_field :ndata_rank ndata)))
+  (let ( (datlis (unsafe_get_field :nctx_datalist nctx)) )
+    (assert_msg "check datlis" (is_list datlis))
+    (let ( (lastdat (pair_head (list_last datlis)))  )
+      (if (is_a lastdat class_nrep_data)
+	  (let ( (:long lastrk (get_int (unsafe_get_field :ndata_rank lastdat))) )
+	    (assert_msg "check lastrk" (>i lastrk 0))
+	    (let ( (rkbox (make_integerbox discr_integer (+i 1 lastrk))) )
+	      (unsafe_put_fields ndata :ndata_rank rkbox)
+	      ))
+	(let ( (rkbox1 (make_integerbox discr_integer 1)) )
+	  (unsafe_put_fields ndata :ndata_rank rkbox1)
+	  )))
+    (list_append datlis ndata)
+ ;   (debug_msg "add_nctx_data final ndata" ndata (the_callcount))
+    ndata
+    ))
+
+
+
+;;; create a normalization context
+(defun create_normcontext ()
+  (let ( (:long maxpredefix (last_globpredef_index))
+	 (:long ix 1)
+	 (predefmap (make_mapobject discr_mapobjects (+i 19 (*i 2 maxpredefix))))
+	 (valmap (make_mapobject discr_mapobjects 350))
+	 )
+    (forever predefloop
+	     (if (>=i ix maxpredefix) (exit predefloop))
+	     (let ( (curpredef (get_globpredef ix)) )
+	       (if (is_object curpredef)
+		   (mapobject_put predefmap curpredef (make_integerbox discr_integer ix)))
+	       )
+	     (setq ix (+i ix 1)))
+    (debug_msg "creatnormctx predefmapdbg" predefmap (the_callcount))
+    (make_instance class_normcontext
+		   :nctx_initproc (make_instance class_nrep_initproc
+						 :ninit_topl (make_list discr_list)
+						 :nrep_loc ()
+						 )
+		   :nctx_proclist (make_list discr_list)
+		   :nctx_datalist (make_list discr_list)
+		   :nctx_symbmap  (make_mapstring discr_mapstrings 50)
+		   :nctx_keywmap  (make_mapstring discr_mapstrings 40)
+		   :nctx_predefmap predefmap
+		   :nctx_valmap valmap
+		   :nctx_valbindmap (make_mapobject discr_mapobjects 20)
+; cold-basilys.lisp don't know how to put a null field, so we comment it out
+;;		   :nctx_symbcachemap ()
+		   )))
+
+;;; the normal_exp selector 
+;;;;; expected arguments: 
+;;;   recv = the reciever, eg a sexpr
+;;;   env = the environment 
+;;;   ncx = the normalization context 
+;;;   psloc = (parent) source location
+;;;;; expected results: normalized + binding list 
+(defselector normal_exp class_selector
+  :named_name (stringconst2val discr_namestring "NORMAL_EXP"))
+
+;; many stuff are already normalized 
+(defun normexp_identical (recv env ncx psloc)
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  ;; is a no-op
+  recv)
+
+(install_method discr_anyrecv normal_exp  normexp_identical)
+
+;;; catchall for src
+(defun normexp_src_catchall (recv env ncx psloc)
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (debug_msg "normexp_src_catchall recv" recv (the_callcount))
+  (let ( (myclass (discrim recv))
+	 (myclassname (unsafe_get_field :named_name myclass)) )
+    (error_strv (unsafe_get_field :src_loc recv) 
+		"unimplemented normalization for " myclassname)
+    (assert_msg "normexp_src_catchall unimplemented normexp for src" ())
+    ))
+(install_method class_src normal_exp normexp_src_catchall)
+
+;; the selector to compute the ctype of a value in an environment
+;;; argument: environment
+;;;; sometimes this selector is used with a null environment, for
+;;;; instance in the code generation phase
+(defselector get_ctype class_selector
+  :named_name (stringconst2val discr_namestring "GET_CTYPE")
+)
+;;; most stuff are really ctype_value
+(defun gectyp_anyrecv (recv env) ctype_value)
+(install_method discr_anyrecv get_ctype gectyp_anyrecv)
+
+(defun gectyp_root (recv env) ctype_value)
+(install_method class_root get_ctype gectyp_root)
+
+;; integers are ctype_long
+(defun gectyp_integer (recv env) 
+  (debug_msg "gectyp_integer recv" recv)
+  ctype_long)
+(install_method discr_integer get_ctype gectyp_integer)
+
+;; strings are ctype_cstring
+(defun gectyp_string (recv env)
+  ctype_cstring)
+(install_method discr_string get_ctype gectyp_string)
+
+;;; normalize a tuple - returning a tuple & a bindinglist
+(defun normalize_tuple (tup env ncx psloc)
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (assert_msg "check tup" (is_multiple tup))
+  (debug_msg "normalize_tuple tup" tup (the_callcount))
+  (let ( (bindlist (make_list discr_list)) 
+	 (res (multiple_map
+	       tup 
+	       (lambda (comp :long ix)
+		 (debug_msg "normalize_tuple comp" comp (the_callcount))
+		 (multicall 
+		  (norcomp nbinds)
+		  (normal_exp comp env ncx psloc)
+		  (assert_msg "check nbinds" (is_list_or_null nbinds))
+		  (debug_msg "normalize_tuple norcomp" norcomp (the_callcount))
+		  (debug_msg "normalize_tuple nbinds" nbinds (the_callcount))
+		  (if (is_list nbinds)
+		      (list_iterate 
+		       nbinds
+		       (lambda (bnd)
+			 (assert_msg "check bnd" (is_a bnd class_any_binding))
+			 (assert_msg "check bindlist" (is_list bindlist))
+			 (debug_msg "normalize_tuple bnd" bnd (the_callcount))
+			 (list_append bindlist bnd)
+			 bnd
+			 ))		
+		    )
+		  norcomp
+		  ))))
+	 )
+    (if (not (is_pair (list_first bindlist)))
+	(setq bindlist ()))
+    (debug_msg "normalize_tuple res" res (the_callcount))
+    (debug_msg "normalize_tuple bindlist" bindlist (the_callcount))
+    (return res bindlist)
+    ))
+
+
+;; wrap a normal let around a tuple of normalized expressions and a bindinglist
+(defun wrap_normal_letseq (tupnexp bindlist loc)
+;  (debug_msg "wrap_normal_letseq tupnexp" tupnexp (the_callcount))
+;  (debug_msg "wrap_normal_letseq bindlist" bindlist (the_callcount))
+  (assert_msg "check tupnexp" (is_multiple_or_null tupnexp))
+  (assert_msg "check bindlist" (is_list_or_null bindlist))
+  (list_iterate
+   bindlist 
+   (lambda (cbind) 
+     (assert_msg "check cbind wrapnormletseq" (is_a cbind class_normlet_binding)) 
+     cbind))
+  (let ( (wnlet
+	  (make_instance class_nrep_let
+			 :nrep_loc loc
+			 :nlet_bindings (list_to_multiple bindlist)
+			 :nlet_body tupnexp))
+	 )
+ ;   (debug_msg "wrap_normal_letseq wnlet" wnlet (the_callcount))
+    wnlet))
+    
+
+;; wrap a normal let around a single normalized expression & a bindinglist
+(defun wrap_normal_let1 (nexp bindlist loc)
+ ; (debug_msg "wrap_normal_let1 nexp" nexp (the_callcount))
+ ; (debug_msg "wrap_normal_let1 bindlist" bindlist (the_callcount))
+  (assert_msg "check bindlist" (is_list_or_null bindlist))
+  (list_iterate
+   bindlist 
+   (lambda (cbind) 
+     (assert_msg "check cbind wrapnormlet1" (is_a cbind class_normlet_binding)) 
+     cbind))
+  (or nexp (shortbacktrace_dbg "wrap_normal_let1 null nexp" 15))
+  (if 
+      (and (is_list bindlist)
+	   (is_pair (list_first bindlist)))
+      (let ( (wnlet 
+	      (make_instance class_nrep_let
+			     :nrep_loc loc
+			     :nlet_bindings (list_to_multiple bindlist)
+			     :nlet_body (make_tuple1 discr_multiple nexp)))
+	     )
+;	(debug_msg "wrap_normal_let1 wnlet" wnlet (the_callcount))
+	wnlet)
+    nexp
+))
+
+
+; for symbols which are imported from a previous environment (this
+; only happens when compiling stuff which is not this warm-basilys) we
+; should detect them and generate some special data to fetch them, in
+; the start routine, from the given environment (which is the only
+; argument to the start routine). Detecting such symbols is easy : their
+; binding is a class_value_binding
+
+;;;; normalize a symbol occurrence
+(defun normexp_symbol (recv env ncx psloc)
+  (multicall
+   (bind procs)
+   (find_enclosing_env env recv)
+   (debug_msg "normexp_symbol recv" recv)
+   (debug_msg "normexp_symbol psloc" psloc)
+   (debug_msg "normexp_symbol bind" bind)
+   (debug_msg "normexp_symbol procs" procs)
+   (if (null bind)
+       (progn
+	 (error_strv psloc "unbound symbol to normalize"
+		     (unsafe_get_field :named_name recv))
+	 (return)))
+   (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx))
+	  (syca (mapobject_get sycmap recv)) )
+     (assert_msg "check sycmap" (is_mapobject sycmap))
+     (cond 
+      ;; check if in the cache
+      (syca syca)	     ;already cached
+      ;; value binding, get/put it into the map
+      ( (is_a bind class_value_binding)
+	(let ( (bvar (mapobject_get (unsafe_get_field :nctx_valbindmap ncx) bind)) )
+	  (debug_msg "normexp_symbol value bind" bind (the_callcount))
+	  (or bvar 
+	      (let ( (newbvar 
+		      (make_instance class_nrep_startval
+				     :nrep_loc psloc
+				     :nstart_var recv)) )
+		(mapobject_put (unsafe_get_field :nctx_valbindmap ncx) bind newbvar)
+		newbvar)
+	      ))
+	)
+      ;; the procs is a non-empty list, so the symbol is closed
+      ( (and (is_list procs)
+	     (is_pair (list_first procs)))
+	;; check that a closed symbol is always a value
+	(let ( (bty
+		(cond ( (is_a bind class_formal_binding)
+			(unsafe_get_field :fbind_type bind) )
+		      ( (is_a bind class_let_binding)
+			(unsafe_get_field :letbind_type bind))
+		      (:else ()))) 
+	       )
+	  (if bty 
+	      (if (!= bty ctype_value)
+		  (error_strv psloc
+			      "closed variable has non value type (boxing required)"
+			      (unsafe_get_field :named_name recv)
+			      )))
+	  (setq bty ctype_value
+		)
+	  (if (is_a bind class_fixed_binding)
+	      (let ( (fxocc
+		      (make_instance class_nrep_constocc
+				     :nrep_loc psloc
+				     :nocc_symb recv
+				     :nocc_bind bind
+				     :nocc_ctyp ctype_value
+				     :ncloc_procs procs)) )
+		;; cache the result
+		(mapobject_put sycmap recv fxocc)
+		(debug_msg "normexp_symbol fxocc" fxocc)
+		;; put the const occurrence if needed in the const list of each proc
+		(list_iterate 
+		 procs
+		 (lambda (pr)
+		   (assert_msg "check pr" (is_a pr class_nrep_anyproc))
+		   (let ( (clbox (make_box discr_box fxocc))
+			  (cnstproc (unsafe_get_field :nrpro_const pr)) )
+		     (list_iterate 
+		      cnstproc
+		      (lambda (cx) (if (== cx fxocc) (progn (box_put clbox ()) ()) cx)))
+		     (let ( (newcl (box_content clbox)) )
+		       (if newcl (list_append cnstproc newcl))) 
+		     )
+		   pr
+		   )
+		 )
+		fxocc
+		)
+	    (let ( (clocc 
+		    (make_instance class_nrep_closedocc
+				   :nrep_loc psloc
+				   :nocc_symb recv
+				   :nocc_ctyp ctype_value
+				   :nocc_bind bind
+				   :ncloc_procs procs)) 
+		   )
+	      ;; cache the result
+	      (mapobject_put sycmap recv clocc)
+	      ;; put the closed occurrence if needed in the closed list of each proc
+	      (list_iterate 
+	       procs
+	       (lambda (pr)
+		 (debug_msg "normexp_symbol closed pr" pr)
+		 (assert_msg "check pr" (is_a pr class_nrep_anyproc))
+		 (let ( (clbox (make_box discr_box clocc))
+			(clobindl (unsafe_get_field :nrpro_closedb pr)) )
+		   (list_iterate 
+		    clobindl
+		    (lambda (clbnd) (if (== clbnd bind) (progn (box_put clbox ()) ()) clbnd)))
+		   (let ( (newcl (box_content clbox)) )
+		     (if newcl (list_append clobindl bind))) 
+		   )
+		 pr
+		 )
+	       )
+	      clocc
+	      ) ) ) ) 
+      ;; formal arg is a local
+      ( (is_a bind class_formal_binding)
+	(let ( (syocc
+		(make_instance class_nrep_locsymocc
+			       :nrep_loc psloc
+			       :nocc_ctyp (unsafe_get_field :fbind_type bind) 
+			       :nocc_symb recv
+			       :nocc_bind bind) ) )
+	  ;; cache the result & return it
+	  (mapobject_put sycmap recv syocc)
+	  syocc
+	  ))
+      ;; let binding is a local
+      ( (is_a bind class_let_binding)
+	(let ( (syocc
+		(make_instance class_nrep_locsymocc
+			       :nrep_loc psloc
+			       :nocc_ctyp (unsafe_get_field :letbind_type bind)
+			       :nocc_symb recv
+			       :nocc_bind bind) ) )
+	  ;; cache the result & return it
+	  (mapobject_put sycmap recv syocc)
+	  syocc
+	  ))
+      ;; all other cases are constants
+      (:else 
+       (debug_msg "normexp_symbol const? bind" bind)
+       (let ( (kocc
+	       (make_instance class_nrep_constocc
+			      :nrep_loc psloc
+			      :nocc_ctyp ctype_value
+			      :nocc_symb recv
+			      :nocc_bind bind) ) )
+	 ;; cache the result & return it
+	 (mapobject_put sycmap recv kocc)
+	 ;; put the const occurrence if needed in the const list of each proc
+	 (list_iterate 
+	  procs
+	  (lambda (pr)
+	    (debug_msg "normexp_symbol const pr" pr)
+	    (assert_msg "check pr" (is_a pr class_nrep_anyproc))
+	    (let ( (clbox (make_box discr_box kocc))
+		   (constproc (unsafe_get_field :nrpro_const pr)) )
+	      (list_iterate 
+	       constproc
+	       (lambda (cl) (if (== cl kocc) (progn (box_put clbox ()) ()) cl)))
+	      (let ( (newcl (box_content clbox)) )
+		(if newcl (list_append constproc newcl))) 
+	      )
+	    pr
+	    )
+	  )
+	 kocc
+	 ))))))
+
+(install_method class_symbol normal_exp normexp_symbol)
+
+(defun gectyp_symocc (recv env)
+  (assert_msg "check recv" (is_a recv class_nrep_symocc))
+  (unsafe_get_field :nocc_ctyp recv)
+)
+(install_method class_nrep_symocc get_ctype gectyp_symocc)
+
+
+;;; normalize a primitive invocation
+(defun normexp_primitive (recv env ncx psloc)
+  (assert_msg "check prim recv" (is_a recv class_src_primitive))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (let ( (sloc (unsafe_get_field :src_loc recv)) 
+	 (soper (unsafe_get_field :sprim_oper recv))
+	 (sargs (unsafe_get_field :sprim_args recv)) 
+	 )
+    (assert_msg "check soper" (is_a soper class_primitive))
+    (multicall 
+     (nargs nbind)
+     (normalize_tuple sargs env ncx sloc)
+     (let ( (sopnamstr (unsafe_get_field :named_name soper))
+	    (sopformals (unsafe_get_field :prim_formals soper))
+	    (soptype (unsafe_get_field :prim_type soper))
+	    (sopexp (unsafe_get_field :prim_expansion soper)) 
+	    (:long nbarg (multiple_length nargs))
+	    (:long nbexp (multiple_length sopexp))
+	    )
+       (or (==i nbarg (multiple_length sopformals))
+	   (progn
+	     (error_strv sloc "length mismatch between formals & actuals in primitive" 
+			 sopnamstr)
+	     (return))
+	   )
+       (let ( (bmap (make_mapobject  discr_mapobjects (+i 2 (/iraw (*i 3 nbarg) 2))))
+	      (expargs (make_multiple discr_multiple nbexp))
+	      )
+	 (multiple_iterate
+	  sopformals
+	  (lambda (forb :long ix)
+	    (assert_msg "check forb" (is_a forb class_formal_binding))
+	    (let ( (forarg (unsafe_get_field :binder forb))
+		   (actarg (multiple_nth nargs ix)) )
+	      (mapobject_put bmap forarg actarg)
+	      bmap
+	      )))
+	 (multiple_iterate
+	  sopexp
+	  (lambda (exc :long jx)
+	    (let ( (exval
+		    (if (is_a exc class_symbol)
+			(let ( (bval (mapobject_get bmap exc)) )
+			  (or bval (error_strv sloc "unbound symbol in primitive expansion" 
+					       (unsafe_get_field  :named_name exc))))
+		      exc)) )
+	      (multiple_put_nth expargs jx exval))
+	    sopexp
+	    ))
+	 (let ( (csym (clone_symbol  (unsafe_get_field :sdef_name soper))) 
+		(clocc (make_instance class_nrep_locsymocc
+				      :nrep_loc sloc
+				      :nocc_ctyp soptype
+				      :nocc_symb csym)) 
+		(cbind (make_instance class_normlet_binding
+				      :letbind_loc sloc
+				      :binder csym
+				      :letbind_type soptype 
+				      :letbind_expr 
+				      (make_instance class_nrep_chunk
+						     :nrep_loc sloc
+						     :nchunk_expansion expargs
+						     :nchunk_primitive soper
+						     ))) 
+		)
+	   (unsafe_put_fields clocc :nocc_bind cbind)
+	   (if (is_list nbind) 
+	       (list_append nbind cbind)
+	     (progn
+	       (setq nbind (make_list discr_list))
+	       (list_append nbind cbind)
+	       ))
+	   (return
+	    clocc
+	    nbind
+	    )))))))
+
+(install_method class_src_primitive normal_exp normexp_primitive)
+(install_method class_nrep_chunk get_ctype 
+		(lambda (recv env)
+		  (let ( ( prim (unsafe_get_field :nchunk_primitive recv)) )
+		    (assert_msg "check prim" (is_a prim class_primitive))
+		    (unsafe_get_field :prim_type prim))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; normalize an application
+(defun normexp_apply (recv env ncx psloc)
+  (assert_msg "check apply recv" (is_a recv class_src_apply))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (let ( (sloc (unsafe_get_field :src_loc recv)) 
+	 (sfun (unsafe_get_field :sapp_fun recv))
+	 (sargs (unsafe_get_field :sapp_args recv))
+	 (sfusymb (if (is_a sfun class_symbol) sfun '_fun_))
+	 )
+    (multicall 
+     (nfun nbindfun)
+     (normal_exp sfun env ncx sloc)
+     (assert_msg "check nbindfun" (is_list_or_null nbindfun))
+     (multicall
+      (nargs nbindargs)
+      (normalize_tuple sargs env ncx sloc)
+      (assert_msg "check nbindargs" (is_list_or_null nbindargs))
+      (setq nbindargs (list_append2list nbindargs nbindfun))
+      (let ( (csym (clone_symbol sfusymb))
+	     (clocc  (make_instance  class_nrep_locsymocc
+				     :nrep_loc sloc
+				     :nocc_ctyp ctype_value
+				     :nocc_symb csym)) 
+	     (cbind (make_instance class_normlet_binding
+				   :letbind_loc sloc
+				   :binder csym
+				   :letbind_type ctype_value 
+				   :letbind_expr 
+				   (make_instance class_nrep_apply
+						  :nrep_loc sloc
+						  :napp_fun nfun
+						  :napp_args nargs
+						  ))) )
+	(unsafe_put_fields clocc :nocc_bind cbind)
+	(or (is_list nbindargs) 
+	    (setq nbindargs (make_list discr_list)))
+	(list_append nbindargs cbind)
+	(return clocc nbindargs)
+	)))))
+(install_method class_src_apply normal_exp normexp_apply)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; normalize a return
+(defun normexp_return (recv env ncx psloc)
+  (assert_msg "check return recv" (is_a recv class_src_return))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (let ( (sloc (unsafe_get_field :src_loc recv)) 
+	 (srets (unsafe_get_field :sreturn_body recv))
+	 (:long nbrets (multiple_length srets)))
+    ;; special case for empty return
+    (if (<=i nbrets 0)
+	(make_instance class_nrep_return
+		       :nrep_loc sloc
+		       :nret_main ()
+		       :nret_rest ())
+      (multicall
+       (nrets nbindrets)
+       (normalize_tuple srets env ncx sloc)
+       (let ( (nret0 (multiple_nth nrets 0))
+	      (toth (make_multiple discr_multiple (-i nrets 1))) 
+	      (ctyp0 (get_ctype nret0 env))
+	      )
+	 (if (!= ctyp0 ctype_value)
+	     (error_plain sloc "main return is not a value"))
+	 (multiple_iterate
+	  nrets
+	  (lambda (ncomp :long ix)
+	    (if (>i ix 0)
+		(multiple_put_nth toth (-i ix 1) ncomp))
+	    toth))
+	 (return
+	  (make_instance class_nrep_return
+			 :nrep_loc sloc
+			 :nret_main nret0
+			 :nret_rest (if (>i nbrets 0) toth))
+	  nbindrets
+	  ))))))
+(install_method class_src_return normal_exp normexp_return)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; normalize an if
+(defun normexp_if (recv env ncx psloc)
+  (assert_msg "check if recv" (is_a recv class_src_if))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (let ( (sloc (unsafe_get_field :src_loc recv))
+	 (stest (unsafe_get_field :sif_test recv))
+	 (ctypif ctype_void)
+	 (sthen (unsafe_get_field :sif_then recv))
+	 (selse (unsafe_get_field :sif_else recv))
+	 )
+;    (debug_msg "normexp_if recv" recv (the_callcount))
+    (multicall 
+     (ntest nbindif) ;nbindif is also the whole result binding
+     (normal_exp stest env ncx sloc)
+     (assert_msg "check nbindif test" (is_list_or_null nbindif))
+;     (debug_msg "normexp_if ntest" ntest (the_callcount))
+;     (debug_msg "normexp_if nbindif" nbindif (the_callcount))
+     ;; in practice we don't need to make a common super-
+     ;; environment with nbindif since all relevant bindings there are
+     ;; generated, with unique cloned symbols, and these bindings 
+     ;; are local to the test part
+     (multicall 
+      (nthen nbindthen)
+      (normal_exp sthen env ncx sloc)
+      (assert_msg "check nbindthen" (is_list_or_null nbindthen))
+;      (debug_msg "normexp_if nthen" nthen (the_callcount))
+;      (debug_msg "normexp_if nbindthen" nbindthen (the_callcount))
+      (let ( (newthenenv (fresh_env env)) )
+	(list_iterate 
+	 nbindthen
+	 (lambda (b) (put_env newthenenv b) newthenenv))
+	;; the ctyp of the whole if is initialized to the ctype of the then part
+	(setq ctypif (get_ctype nthen newthenenv))
+;	(debug_msg "normexp_if ctypif from then" ctypif (the_callcount))
+	(multicall 
+	 (nelse nbindelse)
+	 (normal_exp selse env ncx sloc)
+	 (assert_msg "check nbindelse" (is_list_or_null nbindelse))
+;	 (debug_msg "normexp_if nelse" nelse (the_callcount))
+;	 (debug_msg "normexp_if nbindelse" nbindelse (the_callcount))
+	 ;; if we have both then & else branches,
+	 ;; ensure their compatibility of types
+	 (and nthen nelse
+	      (let ( (ctypthen ctypif) ; only for clarity since ctypif initialized from then part
+		     (newelseenv (let ( (nenv (fresh_env env)) )
+				   (list_iterate 
+				    nbindelse
+				    (lambda (b) (put_env nenv b) nenv))
+				   nenv
+				   ))
+		     (ctypelse (get_ctype nelse newelseenv))
+		     )	
+;		(debug_msg "normexp_if ctypelse" ctypelse (the_callcount))	
+		(and
+		 (!= ctypthen ctype_void)
+		 (!= ctypelse ctype_void)
+		 (!= ctypthen ctypelse)
+		 (progn
+		   (debug_msg "normexp_if incompatyp nthen" nthen)
+		   (debug_msg "normexp_if incompatyp nelse" nelse)
+		   (debug_msg "normexp_if incompatyp ctypthen" ctypthen)
+		   (debug_msg "normexp_if incompatyp ctypelse" ctypelse)
+		   (error_plain sloc 
+				"incompatible types in conditional branches")
+		   )
+		 )
+		))
+	 (let ( (csym (clone_symbol '_if_))
+		(clocc  (make_instance  class_nrep_locsymocc
+					:nrep_loc sloc
+					:nocc_ctyp ctypif
+					:nocc_symb csym)) 
+		(wthen (wrap_normal_let1 nthen nbindthen sloc))
+		(welse (wrap_normal_let1 nelse nbindelse sloc))
+		(cbind (make_instance class_normlet_binding
+				      :letbind_loc sloc
+				      :binder csym
+				      :letbind_type ctypif 
+				      :letbind_expr 
+				      (make_instance class_nrep_if
+						     :nrep_loc sloc
+						     :nif_test ntest
+						     :nif_then wthen
+						     :nif_else welse
+						     :nif_ctyp ctypif
+						     ))) )
+	   (unsafe_put_fields clocc :nocc_bind cbind)
+	   (or (is_list nbindif) 
+	       (setq nbindif (make_list discr_list)))
+	   (list_append nbindif cbind)
+;	   (debug_msg "normexp_if resulting clocc" clocc (the_callcount))
+;	   (debug_msg "normexp_if resulting nbindif" nbindif (the_callcount))
+	   (return clocc nbindif)
+	   )))))))
+(install_method class_src_if normal_exp normexp_if)
+(install_method class_nrep_if get_ctype 
+		(lambda (recv env) (unsafe_get_field :nif_ctyp recv)))
+
+;;;;;;;;;;;;;;;; normalize an or
+;; (OR a1) is a1
+;; (OR a1 a2) is (IF a1 a1 a2) -- ie let aa1 = a1 in (IF aa1 aa1 a2)
+;; (OR a1 a2 a3) is let aa1 = a1 in (IF aa1 aa1 (let aa2=a2 in (IF aa2 aa2 a3)))
+(defun normexp_or (recv env ncx psloc)
+  (assert_msg "check or recv" (is_a recv class_src_or))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (let ( (sloc (unsafe_get_field :src_loc recv))
+	 (sdisj (unsafe_get_field :sor_disj recv))
+	 (:long nbdisj (multiple_length sdisj))
+	 (:long ix (-i nbdisj 1))
+	 (nor ())
+	 (ctyp ctype_void)
+	 (nbind (make_list discr_list))
+	 )
+    (forever backloop
+	     (if (<i ix 0) (exit backloop))
+	     (let ( (curdis (multiple_nth sdisj ix)) )
+	       (multicall 
+		(ncur nbindcur)
+		(normal_exp curdis env ncx sloc)
+		(assert_msg "check nbindcur" (is_list_or_null nbindcur))
+		(let ( (newenv (fresh_env env)) )
+		  (list_iterate 
+		   nbindcur
+		   (lambda (b) (put_env newenv b) newenv))
+		  (if nor
+		      (let ( (csym (clone_symbol '_or_))
+			     (clocc  (make_instance  class_nrep_locsymocc
+						     :nrep_loc sloc
+						     :nocc_symb csym)) 
+			     (ctypcur (get_ctype ncur newenv)) 
+			     (cbind (make_instance class_normlet_binding
+						   :letbind_loc sloc
+						   :binder csym
+						   :letbind_type ctypcur
+						   :letbind_expr nbindcur
+						   ))
+			     (nif (make_instance class_nrep_if
+						 :nrep_loc sloc
+						 :nif_test clocc
+						 :nif_then clocc
+						 :nif_else nor
+						 :nif_ctyp ctypcur))
+				    )
+			(unsafe_put_fields clocc :nocc_bind cbind)
+			(if (not (is_list nbindcur)) (setq nbindcur (make_list discr_list)))
+			(and (!= ctypcur ctyp)
+			     (!= ctypcur ctype_void)
+			     (!= ctyp ctype_void)
+			     (error_plain sloc "incompatible types in OR"))
+			(if (== ctyp ctype_void) (setq ctyp ctypcur))
+			(list_append nbindcur cbind)
+			(setq nor (wrap_normal_let1 clocc nbindcur sloc))
+			     )))))
+	     (setq ix (-i ix 1))
+	     )
+    (return nor (make_list discr_list))
+    ))
+(install_method class_src_or normal_exp normexp_or)
+
+;;;;;; normalize a PROGN
+;;;; (PROGN a1 a2 ... an) is (PROGN (let aa1 = a1 in NULL) (let aa2 = a2 in NULL) ... & aan ; with aan = an
+(defun normexp_progn (recv env ncx psloc)
+  (assert_msg "check progn recv" (is_a recv class_src_progn))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (let ( (sloc (unsafe_get_field :src_loc recv))
+	 (sbody (unsafe_get_field :sprogn_body recv))
+	 (:long lnbody (multiple_length sbody)) 
+	 (boxlnbody (make_integerbox discr_integer lnbody))
+	 (nseq (if (>i lnbody 1) (make_multiple discr_multiple (-i lnbody 1))))
+	 (slast (if (>i lnbody 0) (multiple_nth sbody (-i lnbody 1))))
+	 )
+    (multiple_iterate 
+     sbody
+     (lambda (comp :long ix)
+       (if (<i ix (-i (get_int boxlnbody) 1))
+	   (multicall
+	    (ncur nbindcur)
+	    (normal_exp comp env ncx sloc)
+	    (assert_msg "check nbindcur" (is_list_or_null nbindcur))
+	    (or (is_list nbindcur) (setq nbindcur (make_list discr_list)))
+	    (let ( (newenv (fresh_env env)) )
+	      (list_iterate 
+	       nbindcur
+	       (lambda (b) (put_env newenv b) newenv))
+	      (let ( (csym (clone_symbol '_progn_))
+		     ;; no need of a lococc
+		     (ctypcur (get_ctype ncur newenv)) 
+		     (cbind (make_instance class_let_binding
+					   :binder csym
+					   :letbind_type ctypcur
+					   :letbind_expr nbindcur
+					   ))
+		     )
+		(list_append nbindcur cbind)
+		;; drop the value since it is not needed, so wrap_let a nil
+		(multiple_put_nth nseq ix (wrap_normal_let1 () nbindcur sloc))
+		)
+	      )))
+       sbody
+       ))
+    (multicall
+     (nlast nbindlast)
+     (normal_exp slast env ncx sloc)
+     (assert_msg "check nbindlast" (is_list_or_null nbindlast))
+     (return (make_instance class_nrep_progn
+			    :nrep_loc sloc
+			    :nprogn_seq nseq
+			    :nprogn_last nlast)
+	     nbindlast)
+     )))
+(install_method class_src_progn normal_exp normexp_progn)
+(install_method class_nrep_progn get_ctype 
+		(lambda (recv env) (get_ctype (unsafe_get_field :nprogn_last recv) env)))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;	 
+;;;;;; normalize a LET
+(defun normexp_let (recv  env ncx psloc)
+  (assert_msg "check let recv" (is_a recv class_src_let))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (debug_msg "normexp_let recv" recv (the_callcount))
+  (let ( (sloc (unsafe_get_field :src_loc recv))
+	 (sbindings (unsafe_get_field :slet_bindings recv))
+	 (sbody (unsafe_get_field :slet_body recv)) 
+	 (newenv (fresh_env env))
+	 (bindlist (make_list discr_list))
+	 )
+    (multiple_iterate 
+     sbindings
+     (lambda (sb :long sbix)
+       (assert_msg "check sb" (is_a sb class_src_letbinding))
+       (debug_msg "normexp_let sb" sb (the_callcount))
+       (let ( (sbloc (unsafe_get_field :src_loc sb))
+	      (sbtyp (unsafe_get_field :sletb_type sb))
+	      (sbinder (unsafe_get_field :sletb_binder sb))
+	      (sbexpr (unsafe_get_field :sletb_expr sb)) 
+	      )
+	 (multicall
+	  (nbdexpr nbindings)
+	  (normal_exp sbexpr newenv ncx sbloc)
+	  (debug_msg "normexp_let nbdexpr" nbdexpr (the_callcount))
+	  (debug_msg "normexp_let nbindings" nbindings (the_callcount))
+	  (let ( (lastnbinding (pair_head (list_last nbindings))) )
+	    ;; common case of a normalized apply or primitive, hence a
+	    ;; gensymed variable which is the last in the nbindings
+	    (if (and
+		 (is_a lastnbinding class_normlet_binding)
+		 (is_a nbdexpr class_nrep_locsymocc)
+		 (== (unsafe_get_field :binder lastnbinding) 
+		     (unsafe_get_field :nocc_symb nbdexpr))
+		 )
+		(let ( (lastnormexp (unsafe_get_field :letbind_expr nbdexpr)) )
+		  (list_iterate
+		   nbindings
+		   (lambda (b)
+		     (if (!= b lastnbinding)
+			 (list_append bindlist b))
+		     b))
+		  (let ( (newcbnd
+			  (make_instance class_normlet_binding
+					 :binder sbinder
+					 :letbind_type (unsafe_get_field :letbind_type lastnbinding)
+					 :letbind_expr (unsafe_get_field :letbind_expr lastnbinding)
+					 :letbind_loc (unsafe_get_field :letbind_loc lastnbinding)))
+			 )
+		    (list_append bindlist newcbnd)
+		    (put_env newenv newcbnd)
+		    (debug_msg "normexp_let newcbnd" newcbnd (the_callcount))
+		    )
+		  )
+	      (progn
+;;; otherwise, eg a plain constant, a complex if...
+		(list_append2list bindlist  nbindings)
+		(let ( (newpbnd 
+			(make_instance class_normlet_binding
+				       :binder sbinder
+				       :letbind_type sbtyp
+				       :letbind_expr nbdexpr
+				       :letbind_loc sbloc)) )
+		  (debug_msg "normexp_let newpbnd" newpbnd (the_callcount))
+		  (list_append bindlist newpbnd)
+		  (put_env newenv newpbnd)
+		  ))
+	      ))))
+       bindlist 			;return on multiple iterate
+       ))
+    ;;; end of loop on source bindings
+    (debug_msg "normexp_let after sb loop bindlist" bindlist (the_callcount))
+    (debug_msg "normexp_let befor normtupl sbody" sbody (the_callcount))
+    (multicall
+     (nbody nbodbindings)
+     (normalize_tuple sbody newenv ncx sloc)
+     (debug_msg "normexp_let nbody" nbody (the_callcount))
+     (debug_msg "normexp_let nbodbindings" nbodbindings (the_callcount))
+     (list_append2list bindlist  nbodbindings)
+     (debug_msg "normexp_let bindlist" bindlist (the_callcount))
+     (assert_msg "normexp_let check bindlist" (is_list_or_null bindlist))
+     (list_iterate
+      bindlist
+      (lambda (cbnd) 
+	(assert_msg "normexp_let check cbnd" (is_a cbnd class_normlet_binding))
+	cbnd))
+     (return 
+      (let ( (nlet
+	      (make_instance class_nrep_let
+			     :nrep_loc sloc
+			     :nlet_bindings (list_to_multiple bindlist discr_multiple)
+			     :nlet_body nbody)) )
+	(debug_msg "normexp_let returning nlet" nlet (the_callcount))
+	(return nlet ())
+	))
+     )))
+(install_method class_src_let normal_exp normexp_let)
+(install_method class_nrep_let get_ctype 
+		(lambda (recv env)
+		  (let ( (lbod (unsafe_get_field :nlet_body recv))
+			 (:long lenb (multiple_length lbod)) )
+		    (if (<=i lenb 0) ctype_void
+		      (get_ctype (multiple_nth lbod (-i lenb 1)) env)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; normalize an UNSAFE_GET_FIELD
+(defun normexp_unsafe_get_field (recv env ncx psloc)
+  (assert_msg "check unsafegetfield recv" (is_a recv class_src_unsafe_get_field))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (debug_msg "normexp unsafeget recv" recv (the_callcount))
+  (let ( (sloc   (unsafe_get_field :src_loc recv))
+	 (sobj   (unsafe_get_field :suget_obj recv))
+	 (sfld   (unsafe_get_field :suget_field recv)) ) 
+    (assert_msg "check sfld" (is_a sfld class_field))
+    (multicall
+     (nobj nbind)
+     (normal_exp sobj env ncx sloc)
+     (return (make_instance class_nrep_unsafe_get_field
+			    :nrep_loc sloc
+			    :nuget_obj nobj
+			    :nuget_field sfld)
+	     nbind
+	     ))))
+(install_method class_src_unsafe_get_field normal_exp normexp_unsafe_get_field)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; normalize an UNSAFE_PUT_FIELDS
+(defun normexp_unsafe_put_fields (recv env ncx psloc)
+  (assert_msg "check unsafeputfields recv" (is_a recv class_src_unsafe_put_fields))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (let ( (sloc   (unsafe_get_field :src_loc recv))
+	 (sobj   (unsafe_get_field :suput_obj recv))
+	 (sfields (unsafe_get_field :suput_fields recv))
+	 (nbfields (multiple_length sfields))
+	 (nfields (make_multiple discr_multiple nbfields))
+	 (nbindlist (make_list discr_list))
+	 )
+    (multicall
+     (nobj nobjbind)
+     (normal_exp sobj env ncx sloc)
+     (list_append2list nbindlist  nobjbind)
+     (multiple_iterate 
+      sfields
+      (lambda (fla :long ix) 
+	(assert_msg "check fla" (is_a fla class_src_fieldassign))
+	(let ( (fld (unsafe_get_field :sfla_field fla))
+	       (exp (unsafe_get_field :sfla_expr fla)) )
+	  (assert_msg "check fld" (is_a fld class_field))
+	  (multicall
+	   (nexp nexpbind)
+	   (normal_exp exp env ncx sloc)
+	   (list_append2list nbindlist  nexpbind)
+	   (let ( (nfla (make_instance class_nrep_fieldassign
+				       :nrep_loc sloc
+				       :nfla_field fld
+				       :nfla_val nexp)) )
+	     (multiple_put_nth nfields ix nfla)
+	     nfla
+	     )))))
+     (return 
+      (make_instance class_nrep_unsafe_put_fields
+		     :nrep_loc sloc
+		     :nuput_obj nobj
+		     :nuput_fields nfields)
+      nbindlist
+     ))))
+(install_method class_src_unsafe_put_fields normal_exp normexp_unsafe_put_fields)
+(install_method class_nrep_unsafe_put_fields get_ctype (lambda (recv env) ctype_void))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; normalize a setq
+(defun normexp_setq (recv env ncx psloc)
+  (assert_msg "check setq recv" (is_a recv class_src_setq))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (debug_msg "normexp setq recv" recv (the_callcount))
+  (let ( (sloc   (unsafe_get_field :src_loc recv))
+	 (svar   (unsafe_get_field :sstq_var recv))
+	 (sexp   (unsafe_get_field :sstq_expr recv)) ) 
+    (assert_msg "check svar" (is_a svar class_symbol))
+    (let ( (nvar (normexp_symbol svar env ncx sloc)) )
+      (multicall
+       (nexp nbind)
+       (normal_exp sexp env ncx sloc)
+       (if (!= (get_ctype nvar env) (get_ctype nexp env))
+	   (error_strv sloc "incompatible type for SETQ"
+		       (unsafe_get_field :named_name svar)))
+       (return (make_instance class_nrep_setq
+			      :nrep_loc sloc
+			      :nstq_var nvar
+			      :nstq_exp nexp)
+	       nbind
+	       )))))
+(install_method class_src_setq normal_exp normexp_setq)
+(install_method class_nrep_setq get_ctype 
+		(lambda (recv env)
+		  (get_ctype (unsafe_get_field :nstq_var recv) env)))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;; normalize a make_instance
+(defun normexp_make_instance (recv env ncx psloc)
+  (assert_msg "check make_instance recv" (is_a recv class_src_make_instance))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (debug_msg "normexp_make_instance recv" recv (the_callcount))
+  (let ( (sloc (unsafe_get_field :src_loc recv))
+	 (sclass (unsafe_get_field :smins_class recv))
+	 (sclabind (unsafe_get_field :smins_clabind recv))
+	 (sfields (unsafe_get_field :smins_fields recv))
+	 (sclasym (if (is_a sclabind class_any_binding) (unsafe_get_field :binder sclabind)))
+	 (cladata (if (is_a sclasym class_symbol) 
+		      (normal_exp sclasym env ncx sloc)))
+	 (bindlist (make_list discr_list))
+	 )
+    (debug_msg "normexp_make_instance cladata" cladata (the_callcount))
+    (if (not (is_a cladata class_nrep))
+	(progn
+	  (error_strv sloc "invalid class in make_instance" (unsafe_get_field :named_name sclass))
+	  (return)))
+    (let ( (nfields 
+	    (multiple_map 
+	     sfields 
+	     (lambda (curflda :long curk)
+	       (assert_msg "check curflda" (is_a curflda class_src_fieldassign))
+	       (let ( (curfloc (unsafe_get_field :src_loc curflda))
+		      (curfield (unsafe_get_field :sfla_field curflda))
+		      (curexp (unsafe_get_field :sfla_expr curflda)) )
+		 (if (null curfloc) (setq curfloc sloc))
+		 (multicall
+		  (nexp nbind)
+		  (normal_exp curexp env ncx curfloc)
+		  (assert_msg "check nbind" (is_list_or_null nbind))
+		  (list_append2list bindlist  nbind)
+		  (make_instance class_nrep_fieldassign
+				 :nrep_loc curfloc
+				 :nfla_field curfield
+				 :nfla_val nexp)
+	       )))))
+	   (nmkins 
+	    (make_instance class_nrep_make_instance
+			   :nrep_loc sloc
+			   :nmins_class sclass
+			   :nmins_cladata cladata
+			   :nmins_fields nfields))
+	   )
+      (debug_msg "normexp_make_instance result nmkins" nmkins (the_callcount))
+      (return nmkins bindlist)
+      )
+    )
+  )
+(install_method class_src_make_instance normal_exp normexp_make_instance)
+(install_method class_src_make_instance get_ctype 
+		(lambda (recv env) ctype_value))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;; normalize a forever
+
+(defun normexp_forever (recv env ncx psloc)
+  (assert_msg "check forever recv" (is_a recv class_src_forever))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (debug_msg "normexp_forever recv" recv (the_callcount))
+  (let ( (sloc   (unsafe_get_field :src_loc recv))
+	 (slbind (unsafe_get_field :slabel_bind recv))
+	 (sbody (unsafe_get_field :sfrv_body recv))
+	 (newenv (fresh_env env))
+	 )
+    (assert_msg "check slbind" (is_a slbind class_label_binding))
+    (put_env newenv slbind)
+    (let ( (resy (clone_symbol (unsafe_get_field :binder slbind))) )
+      (unsafe_put_fields slbind :labind_clonsy resy)
+      (multicall
+       (nbody nbodbindings)
+       (normalize_tuple sbody newenv ncx sloc)
+       (let (
+	     (resbody (if 
+			  (or (null nbodbindings) (null (list_first nbodbindings))) 
+			  nbody
+			(make_tuple1 discr_multiple (wrap_normal_letseq nbody nbodbindings sloc))))
+	     (nforever (make_instance class_nrep_forever
+				      :nrep_loc sloc
+				      :nforever_bind slbind
+				      :nforever_body resbody
+				      :nforever_result resy)) 
+	     )
+	 (debug_msg "normexp_forever return nforever" nforever)
+	 (return nforever ())
+	 )
+       ))))
+(install_method class_src_forever normal_exp normexp_forever)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; normalize an exit
+(defun normexp_exit (recv env ncx psloc)
+  (assert_msg "check exit recv" (is_a recv class_src_exit))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (debug_msg "normexp_exit recv" recv (the_callcount))
+  (let ( (sloc   (unsafe_get_field :src_loc recv))
+	 (slbind (unsafe_get_field :slabel_bind recv))
+	 (sbody (unsafe_get_field :sexi_body recv))
+	 (newenv (fresh_env env))
+	 )
+    (assert_msg "check slbind" (is_a slbind class_label_binding))
+    (put_env newenv slbind)
+    (multicall
+     (nbody nbodbindings)
+     (normalize_tuple sbody newenv ncx sloc)
+     ;; the only interesting value of nbody is the last one
+     (let ( (nexit (make_instance class_nrep_exit
+				  :nrep_loc sloc
+				  :nexit_bind slbind
+				  :nexit_val (multiple_nth nbody (-i (multiple_length nbody) 1)))) )
+       (debug_msg "normexp_exit nexit" nexit (the_callcount))
+       (debug_msg "normexp_exit nbodbindings" nbodbindings (the_callcount))
+       (return nexit nbodbindings)
+       ))))
+(install_method class_src_exit normal_exp normexp_exit)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;; replace in a tupe of normalized stuff the last with a return 
+;;;;;; for normalization of defun-s or lambda-s
+(defun replace_last_by_return (tup env sloc)
+  (assert_msg "check tup" (is_multiple tup))
+  (assert_msg "check env" (is_a env class_environment))
+;  (debug_msg "replacelastret tup" tup (the_callcount))
+  (let ( (:long tuplen (multiple_length tup)) 
+	 (lastcomp (if (>i tuplen 0) (multiple_nth tup (-i tuplen 1)))) )
+;    (debug_msg "replacelastret lastcomp" lastcomp (the_callcount))
+    (cond 
+;;; last expression is already a return - do nothing
+     ( (is_a lastcomp class_nrep_return)
+       )
+;;; last expression is a symbol occurrence (closed or local) - return it if it is a value 
+     ( (is_a lastcomp class_nrep_symocc)
+       (if (== (unsafe_get_field :nocc_ctyp lastcomp) ctype_value)
+	   (multiple_put_nth 
+	    tup  (-i tuplen 1)
+	    (make_instance class_nrep_return
+			   :nrep_loc sloc
+			   :nret_main lastcomp))))
+;;; last expression is a normal data, return it
+     ( (is_a lastcomp class_nrep_data)
+       (multiple_put_nth 
+	tup  (-i tuplen 1)
+	(make_instance class_nrep_return
+		       :nrep_loc sloc
+		       :nret_main lastcomp)))
+;;; no last expression - don't bother to return
+     ( (null lastcomp)
+       )
+;;; last expression is a normalized let, recurse on the body within a new env
+     ( (is_a lastcomp class_nrep_let)
+       (let ( (lbody (unsafe_get_field :nlet_body lastcomp)) 
+	      (lbinding (unsafe_get_field :nlet_bindings lastcomp))
+	      (lloc (unsafe_get_field :nrep_loc lastcomp))
+	      (newenv (fresh_env env))
+	      )
+	 (multiple_iterate 
+	  lbinding
+	  (lambda (bnd :long ix)
+	    (put_env newenv bnd)
+	    bnd
+	    ))
+	 (if (is_multiple lbody) 
+	     (replace_last_by_return lbody newenv lloc))))
+;;; last expression is some more complex normalized stuff
+;;; if it is a value wrap it into a normalized let with return 
+     ( (is_a lastcomp class_nrep)
+       (let ( (lastyp (get_ctype lastcomp env)) 
+	      (loc (unsafe_get_field :nrep_loc lastcomp))
+	      )
+	 (if (== lastyp ctype_value)
+	     (let ( (rclosym (clone_symbol '_retval_))
+		    (rclocc (make_instance class_nrep_locsymocc 
+					   :nrep_loc loc
+					   :nocc_symb rclosym
+					   :nocc_ctyp ctype_value))
+		    (retn (make_instance class_nrep_return
+					 :nrep_loc loc
+					 :nret_main rclocc
+					 ))
+		    (rbind (make_instance class_normlet_binding
+					  :binder rclosym
+					  :letbind_type ctype_value
+					  :letbind_expr lastcomp
+					  :letbind_loc loc
+					  ))
+		    (rbintup (make_tuple1 discr_multiple rbind))
+		    (rlet (make_instance class_nrep_let
+					 :nrep_loc loc
+					 :nlet_bindings rbintup
+					 :nlet_body (make_tuple1 discr_multiple retn)))
+		    )
+	       (unsafe_put_fields rclocc :nocc_bind rbind)
+	       (multiple_put_nth 
+		tup  (-i tuplen 1)
+		rlet)
+	       )))))
+;    (debug_msg "replacelastret final tup" tup (the_callcount))
+    tup ; returns the original tuple
+;;; general case, do nothing 
+    )
+)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;; normalize a DEFUN
+(defun normexp_defun (recv  env ncx psloc)
+  (assert_msg "check defun recv" (is_a recv class_src_defun))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (debug_msg "normexp_defun recv" recv (the_callcount))
+  (let ( (sloc (unsafe_get_field :src_loc recv))
+	 (snam (unsafe_get_field :sdef_name recv))
+	 (sformals (unsafe_get_field :sformal_args recv))
+	 (sbody (unsafe_get_field :sfun_body recv))
+	 (sfubind (find_env env snam))
+	 (newenv (fresh_env env))
+	 (oldproc (unsafe_get_field :nctx_curproc ncx))
+	 (oldsymbcache (unsafe_get_field :nctx_symbcachemap ncx))
+	 (closblis (make_list discr_list))
+	 (nproc (make_instance class_nrep_routproc
+;;; dont forget to put the nil fields at end
+			       :nrep_loc sloc
+			       :nproc_body (the_null) ;filled later
+			       :nrpro_name snam
+			       :nrpro_argb sformals
+			       :nrpro_closedb closblis
+			       :nrpro_const (make_list discr_list)
+			       :nrpro_thunklist (make_list discr_list)
+			       :nrpro_datarout (the_null) ; filled below
+			       :nrpro_dataclos (the_null) ; filled below
+			       ))
+	 (ndatarout (make_instance class_nrep_dataroutine
+				   :ndata_name snam
+				   :ndata_discrx (normal_predef discr_routine ncx sloc "discr_routine")
+				   :ndrou_proc nproc
+				   ))
+	 (ndataclos (make_instance class_nrep_dataclosure
+				   :ndata_name snam
+				   :ndata_discrx  (normal_predef discr_closure ncx sloc "discr_closure")
+				   :ndclo_proc nproc
+				   :ndclo_closv (the_null) ;filled below
+				   ))
+	 )
+    (unsafe_put_fields ncx 
+		       :nctx_curproc nproc
+		       :nctx_symbcachemap (make_mapobject discr_mapobjects 40))
+    (add_nctx_data ncx ndatarout)
+    (add_nctx_data ncx ndataclos)
+    (assert_msg "check sfubind" (is_a sfubind class_function_binding))
+    (unsafe_put_fields nproc :nrpro_datarout ndatarout :nrpro_dataclos ndataclos)
+    (multiple_iterate 
+     sformals
+     (lambda (fbi :long ix)
+       (assert_msg "check fbi" (is_a fbi class_formal_binding))
+       (put_env newenv fbi)
+       fbi))
+    (unsafe_put_fields newenv :env_proc nproc)
+    ;; add nproc into ncx
+    (list_append (unsafe_get_field :nctx_proclist ncx) nproc)
+    (debug_msg "normexp_defun sbody" sbody (the_callcount))
+    (multicall
+     (nbody nbindings)
+     (normalize_tuple sbody newenv ncx sloc)
+;     (debug_msg "normexp_defun nbody" nbody (the_callcount))
+;     (debug_msg "normexp_defun nbindings" nbindings (the_callcount))
+     (multiple_iterate
+      nbindings
+      (lambda (nbi :long ix)
+	(put_env newenv nbi)
+	nbi))
+     (let ( (nrbody (replace_last_by_return nbody newenv sloc)) 
+	    (npbody (wrap_normal_letseq nrbody nbindings sloc))
+	    )
+ ;      (debug_msg "normexp_defun nrbody" nrbody (the_callcount))
+ ;      (debug_msg "normexp_defun npbody" npbody (the_callcount))
+       (unsafe_put_fields nproc  :nproc_body npbody)
+       )
+     (unsafe_put_fields ncx :nctx_curproc oldproc :nctx_symbcachemap oldsymbcache)
+     (let ( (clovtup 
+	     (list_to_multiple 
+	      closblis
+	      discr_multiple
+	      (lambda (bnd)
+		(assert_msg "normexp_defun check bnd" (is_a bnd class_any_binding))
+		(let ( (sy (unsafe_get_field :binder bnd)) 
+		       ;; since sy is a symbol, its normalized form does not add any binding
+		       ;; we normalize it in the *old* environment, not the new one
+		       (nsy (normal_exp sy env ncx sloc))
+		       )
+		  nsy
+		)))) )
+       (unsafe_put_fields ndataclos :ndclo_closv clovtup)
+       )
+     (debug_msg "normexp_defun return nproc" nproc (the_callcount))
+     (return nproc ())
+     )
+    ))
+(install_method class_src_defun normal_exp normexp_defun)
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;; normalize a LAMBDA
+(defun normexp_lambda (recv env ncx psloc)
+  (assert_msg "check lambda recv" (is_a recv class_src_lambda))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (debug_msg "normexp_lambda recv" recv (the_callcount))
+  (let ( (sloc (unsafe_get_field :src_loc recv))
+	 (sargs (unsafe_get_field :slam_argbind recv))
+	 (sbody (unsafe_get_field :slam_body recv))
+	 (savedcachemap (unsafe_get_field :nctx_symbcachemap ncx))
+	 (newenv (fresh_env env))
+	 (oldproc (unsafe_get_field :nctx_curproc ncx))
+	 (snam (clone_symbol 'lambda))
+	 (closedblist (make_list discr_list))
+	 (nproc (make_instance class_nrep_routproc
+			       :nrep_loc sloc
+			       :nproc_body (the_null) ;filled later
+			       :nrpro_name snam
+			       :nrpro_argb sargs
+			       :nrpro_closedb closedblist
+			       :nrpro_const (make_list discr_list)
+			       :nrpro_datarout (the_null) ; filled below
+			       :nrpro_dataclos (the_null) ; not filled
+			       :nrpro_thunklist (make_list discr_list)
+			       ))
+	 (ndatarout (make_instance class_nrep_dataroutine
+				   :ndata_name snam
+				   :ndata_discrx (normal_predef discr_routine ncx sloc "discr_routine")
+				   :ndrou_proc nproc
+				   ))
+	 )
+    (add_nctx_data ncx ndatarout)
+    ;; update the context for the new proc & a fresh symbol cache map
+    (unsafe_put_fields ncx 
+		       :nctx_curproc nproc
+		       :nctx_symbcachemap (make_mapobject discr_mapobjects 40))
+    (unsafe_put_fields nproc :nrpro_datarout ndatarout)
+    (multiple_iterate 
+     sargs
+     (lambda (fbi :long ix)
+       (assert_msg "check fbi" (is_a fbi class_formal_binding))
+       (put_env newenv fbi)
+       fbi))
+    (unsafe_put_fields newenv :env_proc nproc)
+    ;; add nproc into ncx
+    (list_append (unsafe_get_field :nctx_proclist ncx) nproc)
+    (multicall
+     (nbody nbindings)
+     (normalize_tuple sbody newenv ncx sloc)
+     (debug_msg "normexp_lambda closedblist became" closedblist (the_callcount))
+     (multiple_iterate
+      nbindings
+      (lambda (nbi :long ix)
+	(put_env newenv nbi)
+	nbi))
+     (unsafe_put_fields 
+      nproc
+      :nproc_body (wrap_normal_letseq (replace_last_by_return nbody newenv sloc) nbindings sloc)
+      )
+     ;; restore the previous symbol cache map & the old proc and return the normalized lambda
+     (unsafe_put_fields ncx 
+			:nctx_symbcachemap savedcachemap
+			:nctx_curproc oldproc
+			)
+     (debug_msg "normexp_lambda nproc" nproc (the_callcount))
+     (let ( 
+	   ;; we make an anonymous constant for the routine unless in toplevel
+	   (:long insideflag (is_a oldproc class_nrep_routproc))
+	   (krout (if insideflag
+		      (make_instance class_nrep_constant
+				     :nrep_loc sloc
+				     :nconst_sval recv
+				     :nconst_data ndatarout
+				     :nconst_proc oldproc)))
+	   (clovtup 
+	    (list_to_multiple closedblist
+			      discr_multiple
+			      (lambda (bnd)
+				(debug_msg "normexp_lambda bnd" bnd)
+				(assert_msg "normexp_lambda check bnd" (is_a bnd class_any_binding))
+				(let ( (sy (unsafe_get_field :binder bnd)) 
+				       ;; since sy is a symbol, its normalized form does not add any binding
+				       ;; we normalize it in the *old* environment, not the new one
+				       (nsy (normal_exp sy env ncx sloc))
+				       )
+				  nsy))))
+	   (nlambda (make_instance class_nrep_lambda 
+				   :nrep_loc sloc
+				   :nlambda_proc nproc
+				   :nlambda_constrout (if insideflag krout ndatarout)
+				   :nlambda_closedv clovtup
+				   ))
+	   )
+       (if insideflag
+	   (list_append (unsafe_get_field :nrpro_const oldproc) ndatarout))
+       (debug_msg "normexp_lambda nlambda" nlambda (the_callcount))
+       (return nlambda ())
+       ))))
+(install_method class_src_lambda normal_exp normexp_lambda)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+;;; create the normal predef (or fail with a msg) 
+(defun normal_predef (pred ncx sloc msg)
+  (assert_msg "check pred" (is_object pred))
+  (assert_msg "check nctxt"  (is_a ncx class_normcontext))
+  (let ( (predefmap (unsafe_get_field :nctx_predefmap ncx)) 
+	 (brk (mapobject_get predefmap pred)) )
+    (if (or (is_integerbox brk) (is_a brk class_symbol))
+	(make_instance class_nrep_predef
+		       :nrep_loc sloc
+		       :nrpredef brk)
+      (if (is_string msg) 
+	  (progn
+	    (debug_msg "normalpredef predefmap" predefmap (the_callcount))
+	    (debug_msg "normalpredef pred" pred (the_callcount))
+	    (error_strv sloc "not a predef:" msg))
+	))))
+
+
+;; retrieve or create the normalized datasym for a symbol
+(defun normal_symbol_data (sym ncx sloc)
+  ;; sym should be strictly a symbol (not be in a subclass of class_symbol!)
+  (assert_msg "check symb" (== (discrim sym) class_symbol))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (let ( (valmap  (unsafe_get_field :nctx_valmap ncx))
+	 (osydata (mapobject_get valmap sym)) )
+    (or osydata 
+	(let ( (:long syhash (obj_hash sym))
+	       (synamstr (unsafe_get_field :named_name sym))
+	       ;; make the datastring from synamstr
+	       (synamstrdata 
+		(make_instance class_nrep_datastring 
+			       :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
+			       :nstr_string synamstr
+					    ))
+	       (syslots (make_multiple discr_multiple
+				       (multiple_length (unsafe_get_field :class_fields class_symbol))))
+	       (sydata (make_instance class_nrep_datasymbol
+				      :ndata_name sym
+				      :ndata_discrx (normal_predef class_symbol ncx sloc "class_symbol")
+				      :ninst_hash (make_integerbox discr_integer syhash)
+				      :ninst_slots syslots
+				      :ndsy_namestr synamstr))
+	       )
+	  (multiple_put_nth syslots (obj_num named_name) synamstrdata)
+	  (add_nctx_data ncx sydata)
+	  (add_nctx_data ncx synamstrdata)
+	  (mapobject_put valmap sym sydata)
+	  (mapstring_putstr (unsafe_get_field :nctx_symbmap ncx) synamstr sydata)
+	  sydata
+	  ))))
+
+
+
+;; retrieve or create the normalized datakeyword for a keyword
+(defun normal_keyword_data (keyw ncx sloc)
+  ;; keyw should be strictly a keyword (not be in a subclass of class_keyword!)
+  (assert_msg "check keywb" (== (discrim keyw) class_keyword))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (let ( (valmap  (unsafe_get_field :nctx_valmap ncx))
+	 (osydata (mapobject_get valmap keyw)) )
+    (or osydata 
+	(let ( (:long syhash (obj_hash keyw))
+	       (synamstr (unsafe_get_field :named_name keyw))
+	       ;; make the datastring from synamstr
+	       (synamstrdata 
+		(make_instance class_nrep_datastring 
+			       :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
+			       :nstr_string synamstr
+					    ))
+	       (syslots (make_multiple discr_multiple
+				       (multiple_length (unsafe_get_field :class_fields class_keyword))))
+	       (sydata (make_instance class_nrep_datakeyword
+				      :ndata_name keyw
+				      :ndata_discrx (normal_predef class_keyword ncx sloc "class_keyword")
+				      :ninst_hash (make_integerbox discr_integer syhash)
+				      :ninst_slots syslots
+				      :ndsy_namestr synamstr))
+	       )
+	  (multiple_put_nth syslots (obj_num named_name) synamstrdata)
+	  (add_nctx_data ncx sydata)
+	  (add_nctx_data ncx synamstrdata)
+	  (mapobject_put valmap keyw sydata)
+	  (mapstring_putstr (unsafe_get_field :nctx_keywmap ncx) synamstr sydata)
+	  sydata
+	  ))))
+
+
+;; create the tuples of slots of a datainstance for a particular class
+(defun create_data_slots (cla)
+  (assert_msg "check cla" (is_a cla class_class)) 
+  (debug_msg "create_data_slots cla" cla (the_callcount))
+  (let ( (tupslo 
+	  (make_multiple discr_multiple  (multiple_length (unsafe_get_field :class_fields cla)))) 
+	 )
+    (debug_msg "create_data_slots tupslo" tupslo (the_callcount))
+    tupslo
+    ))
+
+;; fill a slot of a datainstance
+(defun fill_data_slot (di field val)
+  (assert_msg "check di" (is_a di class_nrep_datainstance))
+  (assert_msg "check field" (is_a field class_field))
+  (let ( (:long fix (obj_num field))
+	 (slots (unsafe_get_field :ninst_slots di)) )
+    (multiple_put_nth slots fix val)
+))
+
+;;;;;; normalize a QUOTE-d symbol
+
+(defun normexp_quote (recv env ncx psloc)
+  (assert_msg "check quote recv" (is_a recv class_src_quote))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (debug_msg "normexp_quote ncx" ncx (the_callcount))
+  (debug_msg "normexp_quote recv" recv (the_callcount))
+  (let ( (sloc   (unsafe_get_field :src_loc recv))
+	 (quotedsy (unsafe_get_field :squoted recv)) )
+    (assert_msg "check quotedsy" (== (discrim quotedsy) class_symbol))
+    (let ( (sdata (normal_symbol_data quotedsy ncx psloc))
+	   (curproc (unsafe_get_field :nctx_curproc ncx))
+	   (constlist (unsafe_get_field :nrpro_const curproc))
+	   (nconst (make_instance class_nrep_constant
+				  :nrep_loc sloc
+				  :nconst_sval quotedsy
+				  :nconst_data sdata
+				  :nconst_proc curproc
+				  ))
+	   )
+      (assert_msg "check curproc" (is_a curproc class_nrep_routproc))
+      (list_append constlist sdata)
+      (debug_msg "normexp_quote nconst" nconst (the_callcount))
+      nconst
+      )))
+(install_method class_src_quote normal_exp normexp_quote)
+
+;;;;;; normalize a keyword
+(defun normexp_keyword (recv env ncx psloc)
+  (assert_msg "check keyword recv" (is_a recv class_keyword))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (debug_msg "normexp_keyword ncx" ncx (the_callcount))
+  (debug_msg "normexp_keyword recv" recv (the_callcount))
+  (let ( (kdata (normal_keyword_data recv ncx psloc)) 
+	 (curproc (unsafe_get_field :nctx_curproc ncx))
+	 (constlist (unsafe_get_field :nrpro_const curproc))
+	 (nconst (make_instance class_nrep_constant
+				:nrep_loc psloc
+				:nconst_sval recv
+				:nconst_data kdata
+				:nconst_proc curproc))
+	 )
+    (assert_msg "check curproc" (is_a curproc class_nrep_anyproc))
+    (list_append constlist kdata)
+    (debug_msg "normexp_keyword nconst" nconst (the_callcount))
+    nconst
+))
+(install_method class_keyword normal_exp normexp_keyword)
+
+;;;;;; normalize a DEFPRIMITIVE
+(defun normexp_defprimitive (recv env ncx psloc)
+  (assert_msg "check defprimitive recv" (is_a recv class_src_defprimitive))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (let ( (sloc   (unsafe_get_field :src_loc recv))
+	 (sname  (unsafe_get_field :sdef_name recv))
+	 (sargs  (unsafe_get_field :sformal_args recv))
+	 (stype  (unsafe_get_field :sprim_type recv))
+	 (sexp   (unsafe_get_field :sprim_expansion recv))
+	 (sprimbind (find_env env sname))
+	 ;; we compile to the making of an instance of class_primitive
+	 (nslotuple (create_data_slots class_primitive))
+	 (nexptuple (make_multiple discr_multiple
+				   (multiple_length sexp)))
+	 (nargtuple (make_multiple discr_multiple
+				   (multiple_length sargs)))
+	 (nexpdata (make_instance class_nrep_datatuple
+				  :nrep_loc sloc
+				  :ndata_name sname
+				  :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple")
+				  :ntup_comp nexptuple))
+	 (nargdata (make_instance class_nrep_datatuple
+				  :nrep_loc sloc
+				  :ndata_name sname
+				  :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple")
+				  :ntup_comp nargtuple))
+	 (nprimdata (make_instance class_nrep_datainstance
+				   :nrep_loc sloc
+				   :ndata_name sname
+				   :ndata_discrx (normal_predef class_primitive ncx sloc "class_primitive")
+				   :ninst_hash (make_integerbox discr_integer (nonzero_hash))
+				   :ninst_slots nslotuple)) 
+	 (nsymdata (normal_symbol_data sname ncx sloc))
+	 ;; map of formal symbol -> data of formal_binding
+	 (formsymbmap (make_mapobject discr_mapobjects (*i (multiple_length sargs) 2)))
+	 )
+    (add_nctx_data ncx nprimdata)
+    (add_nctx_data ncx nexpdata)
+    (add_nctx_data ncx nargdata)
+    ;; dont add nsymdata, it has already been added
+    ;; fill the formal arguments of the data
+    (multiple_iterate
+     sargs
+     (lambda (fargb :long ix)
+       (assert_msg "check fargb" (is_a fargb class_formal_binding))
+       (let ( (ftyp (unsafe_get_field :fbind_type fargb)) 
+	      (fsymb (unsafe_get_field :binder fargb))
+	      (fdataslot (create_data_slots class_formal_binding))
+	      (fargdata 
+	       (make_instance 
+		class_nrep_datainstance
+		:nrep_loc sloc
+		:ndata_discrx (normal_predef class_formal_binding ncx sloc "class_formal_binding") 
+		:ninst_hash (make_integerbox discr_integer (nonzero_hash))
+		:ninst_slots fdataslot
+		:ninst_objnum (make_integerbox discr_integer ix)
+		))
+	      (fsymbdata (normal_symbol_data fsymb ncx sloc))
+	      (ftypdata (normal_predef ftyp ncx sloc "primitive arg type"))
+	      )
+	 (assert_msg "check ftyp" (is_a ftyp class_ctype))
+	 (add_nctx_data ncx fargdata)
+	 (fill_data_slot fargdata binder fsymbdata)
+	 (fill_data_slot fargdata fbind_type ftypdata)
+	 (multiple_put_nth nargtuple ix fargdata)
+	 (mapobject_put formsymbmap fsymb fargdata)
+	 fargb
+	 )))
+    ;; fill the expansion of the data
+    (multiple_iterate
+     sexp
+     (lambda (expcomp :long ix)
+       (debug_msg "normexp_defprimitive expcomp" expcomp)
+       (let ( (discrcomp (discrim expcomp)) 
+	      (compdata 
+	       (cond ( (== discrcomp discr_verbatimstring)
+		       (add_nctx_data ncx
+				      (make_instance 
+				       class_nrep_datastring
+				       :ndata_discrx (normal_predef discr_verbatimstring ncx sloc "discr_verbatimstring") 
+				       :nstr_string expcomp
+				       )))
+		     ( (== discrcomp class_symbol)
+		       (normal_symbol_data expcomp ncx sloc)
+		       )
+		     ( :else 
+		       (error_plain sloc "unexpected component in primitive expansion"))))
+	      )
+	 (multiple_put_nth nexptuple ix compdata)
+	 compdata
+	 )))
+;;; fill the primitive data    
+    (fill_data_slot nprimdata named_name 
+		    (add_nctx_data 
+		     ncx
+		     (make_instance 
+		      class_nrep_datastring
+		      :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
+		      :nstr_string (unsafe_get_field :named_name sname))))
+    (fill_data_slot nprimdata prim_formals nargdata)
+    (fill_data_slot nprimdata prim_expansion nexpdata)
+;;; put the data into the primitive binding
+    (if (is_a sprimbind class_primitive_binding)
+	(unsafe_put_fields sprimbind :pbind_primdata nprimdata))
+    (return ())			     ;normalized defprimitive is empty
+    ))
+(install_method class_src_defprimitive normal_exp normexp_defprimitive)
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;; normalize a DEFCLASS
+(defun normexp_defclass (recv env ncx psloc)
+  (assert_msg "check defclass recv" (is_a recv class_src_defclass))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (let ( (sloc   (unsafe_get_field :src_loc recv))
+	 (sname  (unsafe_get_field :sdef_name recv))
+	 (spredef (unsafe_get_field :sobj_predef recv))
+	 (sclabind (unsafe_get_field :sclass_clabind recv))
+	 (superbind (unsafe_get_field :sclass_superbind recv))
+	 (sfldbinds (unsafe_get_field :sclass_fldbinds recv))
+	 )
+    (assert_msg "check sclabind" (is_a sclabind class_class_binding))
+    (let ( (claobj (unsafe_get_field :cbind_class sclabind)) 
+	   (namsymdata (normal_symbol_data sname ncx sloc))
+	   (namstrdata
+	    (make_instance class_nrep_datastring
+			   :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
+			   :nstr_string (unsafe_get_field :named_name sname)
+			   ))
+	   (claslots (make_multiple discr_multiple (obj_len claobj)))
+	   (cladata 
+	    (make_instance class_nrep_datainstance
+			   :nrep_loc sloc
+			   :ndata_name sname
+			   :ndata_discrx (normal_predef class_class ncx sloc "class_class")
+			   :ninst_hash  (make_integerbox discr_integer (obj_hash claobj))
+			   :ninst_predef spredef
+			   :ninst_slots claslots
+			   :ninst_objnum 'OBMAG_OBJECT
+			   )) 
+	   (ancseq (unsafe_get_field :class_ancestors claobj))
+	   (:long nbanc (multiple_length ancseq))
+	   (anctup (make_multiple discr_multiple nbanc))
+	   (ancdata (make_instance 
+		     class_nrep_datatuple
+		     :nrep_loc sloc
+		     :ndata_name sname
+		     :ndata_discrx (normal_predef discr_seqclass ncx sloc "discr_seqclass")
+		     :ntup_comp anctup
+		     ))
+	   (fldseq (unsafe_get_field :class_fields claobj))
+	   (:long nbfld (multiple_length fldseq)) ;total number of fields
+	   (:long nbownfld (multiple_length sfldbinds)) ;number of own fields
+	   (:long nbsupfld (-i nbfld nbownfld))	;number of super(ie inherited) fields
+	   (:long ix 0)				;temporary index
+	   (fldtup (make_multiple discr_multiple nbfld))
+	   (flddata (make_instance 
+		     class_nrep_datatuple
+		     :nrep_loc sloc
+		     :ndata_name sname
+		     :ndata_discrx (normal_predef discr_seqfield ncx sloc "discr_seqfield")
+		     :ntup_comp fldtup
+		     ))
+	   ;; the data representing the superclass
+	   (superdata (if (is_a superbind class_any_binding) 
+			  (normal_exp (unsafe_get_field :binder superbind) env ncx sloc)))
+	   )
+      (assert_msg "check claobj" (is_a claobj class_class))
+      (add_nctx_data ncx cladata)
+      (add_nctx_data ncx namstrdata)
+      (add_nctx_data ncx ancdata)
+      (add_nctx_data ncx flddata)
+      (fill_data_slot cladata named_name namstrdata)
+      (fill_data_slot cladata class_ancestors ancdata)
+      (fill_data_slot cladata class_fields flddata)
+      (assert_msg "check sclabind" (is_a sclabind class_class_binding))
+      (unsafe_put_fields sclabind :cbind_cladata cladata)
+      ;; for each field which is not own, make a data to copy it from the superclass
+      (setq ix 0)
+      (forever loopsuperfield
+	       (if (>=i ix nbsupfld) (exit loopsuperfield))
+	       (let ( (supfldata 
+		       (make_instance class_nrep_multacc
+				      :nrep_loc sloc
+				      :naccm_mul
+				      (make_instance class_nrep_fieldacc
+						     :nrep_loc sloc
+						     :naccf_obj superdata
+						     :naccf_fld class_fields
+						     )
+				      :naccm_ix (make_integerbox discr_integer ix)	      
+				      )) 
+		      )
+		 (multiple_put_nth fldtup ix supfldata)
+		 )
+	       (setq ix (+i ix 1))
+	       )
+      (setq ix 0)
+      ;; for each own field, make an instance of it
+      (forever loopownfield
+	       (if (>=i ix nbownfld) (exit loopownfield))
+	       (let ( (ownfldbind (multiple_nth sfldbinds ix)) )
+		 (assert_msg "check ownfldbind" (is_a ownfldbind class_field_binding))
+		 (let ( (ownfldsym (unsafe_get_field :binder ownfldbind))
+			(ownfld (unsafe_get_field :flbind_field ownfldbind))
+			)
+		   (assert_msg "check ownfldsym" (is_a ownfldsym class_symbol))
+		   (assert_msg "check ownfld" (is_a ownfld class_field))
+		   (let ( (ownfldsymdata (normal_symbol_data ownfldsym ncx sloc)) 
+			  (ownfldslots (make_multiple discr_multiple (obj_len ownfld)))
+			  (ownflstrdata 
+			   (make_instance class_nrep_datastring
+					  :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
+					  :nstr_string  (unsafe_get_field :named_name ownfld)
+					  ))
+			  (ownfldata (make_instance class_nrep_datainstance
+						    :nrep_loc sloc
+						    :ndata_name ownfldsym
+						    :ndata_discrx (normal_predef class_field ncx sloc "class_field")
+						    :ninst_hash (make_integerbox discr_integer (obj_hash ownfld))
+						    :ninst_objnum (make_integerbox discr_integer (obj_num ownfld))
+						    :ninst_slots ownfldslots))
+			  )
+		     (add_nctx_data ncx ownfldata)
+		     (add_nctx_data ncx ownflstrdata)
+		     (fill_data_slot ownfldata named_name ownflstrdata)
+		     (fill_data_slot ownfldata fld_ownclass cladata)
+		     (multiple_put_nth fldtup (+i ix nbsupfld) ownfldata)
+		     ;; fill the field binding with its compiled data
+		     (unsafe_put_fields ownfldbind :flbind_fdata ownfldata)
+		     )))
+	       (setq ix (+i ix 1))
+	       )
+      ;; set the disc_super field to the superclass
+      (if superdata (fill_data_slot cladata disc_super superdata))
+      ;; compute the class_ancestors into anctup
+      (setq ix 0)
+      ;; loop on the ancestors of the superclass
+      (forever loopancestorsuper
+	       (if (>=i ix (-i nbanc 1)) (exit loopancestorsuper))
+	       (let ( (supancdata
+		       (make_instance class_nrep_multacc
+				      :nrep_loc sloc
+				      :naccm_mul
+				      (make_instance class_nrep_fieldacc
+						     :nrep_loc sloc
+						     :naccf_obj superdata
+						     :naccf_fld class_ancestors)
+				      :naccm_ix (make_integerbox discr_integer ix))) )
+		 (multiple_put_nth anctup ix supancdata)
+		 )
+	       (setq ix (+i ix 1))
+	       )
+      ;; add the superdata as the last component of anctup
+      (if superdata (multiple_put_nth anctup (-i nbanc 1) superdata))
+      ;; the normalized form of the defclass is the classdata
+      cladata
+      )))
+(install_method class_src_defclass normal_exp normexp_defclass)
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;; normalize a DEFINSTANCE
+(defun normexp_definstance (recv env ncx psloc)
+  (assert_msg "check definstance recv" (is_a recv class_src_definstance))
+  (assert_msg "check env" (is_a env class_environment))
+  (assert_msg "check nctxt" (is_a ncx class_normcontext))
+  (debug_msg "normexp definstance recv" recv (the_callcount))
+  (let ( (sloc   (unsafe_get_field :src_loc recv))
+	 (sname  (unsafe_get_field :sdef_name recv))
+	 (spredef (unsafe_get_field :sobj_predef recv))
+	 (sdocstr (unsafe_get_field :sobj_docstr recv))
+	 (sinstclass (unsafe_get_field :sinst_class recv))
+	 (sinstclabnd (unsafe_get_field :sinst_clabind recv))
+	 (sinstclasym (if (is_a sinstclabnd class_any_binding) (unsafe_get_field :binder sinstclabnd)))
+	 (sinstobjnum (unsafe_get_field :sinst_objnum recv))
+	 (sinstfields (unsafe_get_field :sinst_fields recv))
+	 (nbindlist (make_list discr_list))
+	 (nbindbox (make_box discr_box nbindlist))
+	 (namdata (normal_symbol_data sname ncx sloc))
+	 ;; data representing the class
+	 (icladata (if (is_a sinstclasym class_symbol) 
+		       (normal_exp sinstclasym env ncx sloc)))
+	 )
+    (if (not (is_a icladata class_nrep))
+	(progn
+	  (error_strv sloc "invalid class in definstance" (unsafe_get_field :named_name sname))
+	  (return)))
+    (if spredef
+	(or (is_integerbox spredef) (is_a spredef class_symbol)
+	    (progn (error_strv sloc "bad predef in definstance"  (unsafe_get_field :named_name sname))
+		   (return))))
+    (assert_msg "check sinstclass" (is_a sinstclass class_class))
+    (assert_msg "check sinstclasym" (is_a sinstclasym class_symbol))
+    (let (
+	  (slotup (make_multiple discr_multiple
+				 (multiple_length (unsafe_get_field :class_fields sinstclass))))
+	  (insdata (make_instance class_nrep_datainstance
+				  :nrep_loc sloc
+				  :ndata_name sname
+				  :ndata_discrx icladata
+				  :ninst_hash (make_integerbox discr_integer (nonzero_hash))
+				  :ninst_predef spredef
+				  :ninst_slots slotup
+				  )) 
+	  )
+      (add_nctx_data ncx insdata)
+      ;; scan the fields initialization
+      (multiple_iterate
+       sinstfields
+       (lambda (flda :long ix)
+	 (assert_msg "check flda" (is_a flda class_src_fieldassign))
+	 (let ( (curfld (unsafe_get_field :sfla_field flda))
+		(curexp (unsafe_get_field :sfla_expr flda))
+		(:long curoff (obj_num curfld))
+		)
+	   (assert_msg "check curfld" (is_a curfld class_field))
+	   (assert_msg "good curfld"
+		       (== (multiple_nth (unsafe_get_field :class_fields sinstclass) curoff) 
+			   curfld))  
+	   (multicall
+	    (ncur nbindcur)
+	    (normal_exp curexp env ncx sloc)
+	    (multiple_put_nth slotup curoff ncur)
+	    (if (is_list nbindcur)
+		(let ( (nbindlist (box_content nbindbox)))
+		  (setq nbindlist (list_append2list nbindlist nbindcur))
+		  (box_put nbindbox nbindlist)))
+	    flda			;result of lambda
+	    ))))
+;;; put the binding into the data
+      (let ( (nbindlist (box_content nbindbox)) 
+	     (nbindtup (list_to_multiple nbindlist discr_multiple))
+	     )
+	(if (>i (multiple_length nbindtup) 0) 
+	    (unsafe_put_fields insdata :ndata_locbind nbindtup))
+	;; return the data
+	insdata
+	))))
+(install_method class_src_definstance normal_exp normexp_definstance)
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;;; selector to compile a normalized stuff into an object
+;;; reciever: the normalized stuff
+;;; arguments: 
+;;;; * GCX the code generation context
+;;; result = the obj instruction or value
+
+(defselector compile_obj class_selector
+  :named_name  (stringconst2val discr_namestring "COMPILE_OBJ"))
+;; a catchall method for nrep-s (normal representations) each should
+;; be separately compiled with its own method so this should never be
+;; called
+(defun compilobj_catchall_nrep (recv gcx)
+  (debug_msg "class_rep compile_obj gcx" gcx (the_callcount))
+  (debug_msg "class_rep compile_obj recv" recv (the_callcount))
+  (assert_msg "@@compile_obj should be implemented in nrep-s subclasses" ())
+  )
+(install_method class_nrep compile_obj compilobj_catchall_nrep)
+
+;;; selector to put a destination into an objcode
+;;; reciever: the objcode
+;;; argument: the destination value
+;;; result: the (modified) recieving objcode or its replacement
+(defselector put_objdest class_selector
+  :named_name (stringconst2val discr_namestring "PUT_OBJDEST"))
+
+;;; classes for code generation
+
+
+;;; code generation context
+(defclass class_genercontext
+  :super class_root
+  :fields ( gncx_objrout 		;the containing object routine
+	    gncx_locmap			;objmap from normal bindings to locals
+	    gncx_freeptrlist		;list of freed local pointers
+	    gncx_freelonglist		;list of freed local longs
+	    gncx_freeothermaps		;map keyed by ctypes of list of freed local others
+	    gncx_retloc			;return location
+	    gncx_compicache		;cache map of procedure to compiled routines
+))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; common superclass for objcode
+(defclass class_objcode
+  :super class_root
+  :fields (
+))
+(defun putobjdest_catchall_objcode (recv desto)
+  (debug_msg "putobjdest_catchall_objcode recv@@  " recv (the_callcount))
+  (debug_msg "putobjdest_catchall_objcode desto@@  " desto (the_callcount))
+  (shortbacktrace_dbg "putobjdest_catchall_objcode" 15)
+  (assert_msg "@@ unexpected catchall putobjdest" ()))
+(install_method class_objcode put_objdest putobjdest_catchall_objcode)
+
+;;;; value like objects
+(defclass class_objvalue
+  :super class_objcode
+  :fields ( obv_type			;the ctype
+))
+
+(defun getctype_objvalue (recv env)
+  (assert_msg "check recv objvalue" (is_a recv class_objvalue))
+  obv_type)
+(install_method class_objvalue get_ctype getctype_objvalue)
+
+;; object local variable
+(defclass class_objlocv
+  :super class_objvalue
+  :fields (obl_off			;offset in frame
+	   obl_proc			;containing procedure
+	   obl_cname			;symbolic cname string
+))
+
+
+;; closed occurrence
+(defclass class_objcloccv
+  :super class_objvalue
+  :fields (obc_off			;offset in closure
+	   obc_proc			;containing procedure
+	   obc_name			;symbolic name
+))
+
+;; constant [closed] occurrence
+(defclass class_objconstv
+  :super class_objcloccv
+  :fields (
+))
+
+;; predefined object
+(defclass class_objpredef
+  :super class_objvalue
+  :fields (obpredef
+))
+
+;; initial element 
+(defclass class_objinitelem
+  :super class_objvalue
+  :fields (oie_cname 			;symbolic cname string - fieldname in cdat
+	   oie_data			;normal data
+	   oie_discr			;compiled discriminant
+	   oie_locvar			;initial routine's local variable
+	   ;; the size, if any is the obj_num
+))
+
+;;;; selector to generate the declaration of an initial
+;;; reciever some objinielem
+;;; argument strbuf
+(defselector output_c_declinit class_selector
+  :named_name (stringconst2val discr_namestring "OUTPUT_C_DECLINIT")
+)
+(defun outdeclinit_root (recv sbuf)
+  (debug_msg "outdeclinit_root recv" recv (the_callcount))
+  (assert_msg "outdeclinit_root unimplemented catchall" ())
+)
+(install_method class_root output_c_declinit outdeclinit_root)
+
+
+;;; selector to generate the c code for an object
+;;; reciever: the object to output
+;;; arguments: 
+;;;; * DECLBUF the stringbuffer for the declarations
+;;;; * IMPLBUF the stringbuffer for implementations
+;;;; * DEPTH an unboxed integer for indentation...
+;;; result is not used
+
+(defselector output_c_code class_selector
+  :named_name  (stringconst2val discr_namestring "OUTPUT_C_CODE"))
+
+
+(defun outpucod_objinielem (obielem  declbuf implbuf :long depth)
+  (assert_msg "check obelem" (is_a obielem class_objinitelem))
+  ;;(debug_msg "outpucod_objinielem obielem" obielem (the_callcount))
+  (let ( (olocvar (unsafe_get_field :oie_locvar obielem))
+	 (cnam (unsafe_get_field :oie_cname obielem)) )
+    (assert_msg "check cnam" (is_string cnam))
+    (assert_msg "check olocvar"  olocvar)
+    (add2sbuf_strconst implbuf "/*obielem ")
+    (add2sbuf_string implbuf cnam)
+    (add2sbuf_strconst implbuf "*/ ")
+    (output_c_code olocvar declbuf implbuf depth)
+    )
+)
+(install_method class_objinitelem output_c_code outpucod_objinielem)
+
+;;;; selector to generate the initial fill of some objinit
+;;; reciever some objinitelem
+;;; argument a stringbuffer
+(defselector output_c_initfill class_selector
+  :named_name (stringconst2val discr_namestring "OUTPUT_C_INITFILL"))
+(defun outcinitfill_root (recv declbuf implbuf :long depth)
+  (debug_msg "outcinitfill_root recv" recv (the_callcount))
+  (assert_msg "outcinitfill_root unimplemented catchall" ())
+)
+(install_method class_root output_c_initfill outcinitfill_root)
+
+
+(defun outpucod_predef (obpred declbuf implbuf :long depth)
+  (assert_msg "check obpredef" (is_a obpred class_objpredef))
+  (let ( (obpr (unsafe_get_field :obpredef obpred)) )
+    (cond 
+     ( (is_integerbox obpr)
+       (add2sbuf_strconst implbuf "basilys_globpredef(")
+       (add2sbuf_longdec implbuf (get_int obpr))
+       (add2sbuf_strconst implbuf ")")
+       )
+     ( (is_a obpr class_symbol)
+       (add2sbuf_strconst implbuf "BASILYSG(")
+       (add2sbuf_string implbuf (unsafe_get_field :named_name obpr))
+       (add2sbuf_strconst implbuf ")")
+       )
+     ( :else
+       (debug_msg "bad obpredef" obpredef (the_callcount))
+       (assert_msg "invalid obpredef" ())
+       )
+     )))
+(install_method class_objpredef output_c_code outpucod_predef)
+
+;;; initial object - see BASILYS_OBJECT_STRUCT in basilys.h
+(defclass class_objinitobject
+  :super class_objinitelem
+  :fields (
+	   oio_predef			;the predef name or number to contain this object
+))
+(defun outdeclinit_objinitobject (recv sbuf)
+  (add2sbuf_strconst sbuf " struct BASILYS_OBJECT_STRUCT(")
+  (add2sbuf_longdec sbuf (get_int recv))
+  (add2sbuf_strconst sbuf ") ")
+  (add2sbuf_string sbuf (unsafe_get_field :named_name recv))
+  (add2sbuf_strconst sbuf ";")		;
+)
+(install_method class_objinitobject output_c_declinit outdeclinit_objinitobject)
+
+(defun outcinitfill_objinitobject (recv sbuf)
+  (assert_msg "outcinitfill_objinitobject check recv" (is_a recv class_objinitobject))
+  (debug_msg "outcinitfill_objinitobject recv" recv (the_callcount))
+  (let ( (odata (unsafe_get_field :oie_data recv)) 
+	 (odiscr (unsafe_get_field :oie_discr recv))
+	 (oname (unsafe_get_field :oie_cname recv))
+	 (olocvar (unsafe_get_field :oie_locvar recv))
+	 (oiopredef (unsafe_get_field :oio_predef recv))
+	 )
+    (assert_msg "check odata" (is_a odata class_nrep_datainstance))
+    (let ( (odloc (unsafe_get_field :nrep_loc odata))
+	   (odhash (unsafe_get_field :ninst_hash odata))
+	   (odslots (unsafe_get_field :ninst_slots odata))
+	  )
+      (output_location odloc sbuf 1)
+      (add2sbuf_strconst sbuf "/*iniobj ")
+      (add2sbuf_string sbuf oname)
+      (add2sbuf_strconst sbuf "*/")
+      (add2sbuf_indentnl sbuf 1)
+      (if olocvar
+	  (progn
+	    (add2sbuf_strconst sbuf "/*inioblocvar*/ ")
+	    (output_c_code olocvar (the_null) sbuf 1)
+	    (add2sbuf_strconst sbuf " = (void*)&cdat->")
+	    (add2sbuf_string sbuf oname)
+	    (add2sbuf_strconst sbuf ";")
+	    (add2sbuf_indentnl sbuf 1)
+	    ))
+      (if oiopredef
+	  (cond
+	   ( (is_a oiopredef class_symbol)
+	     (add2sbuf_strconst sbuf "/*iniobpredefsym*/ BASILYSG(")
+	     (add2sbuf_string sbuf (unsafe_get_field :named_name oiopredef))
+	     (add2sbuf_strconst sbuf ") = (void*)&cdat->")
+	     (add2sbuf_string sbuf oname)
+	     (add2sbuf_strconst sbuf ";")
+	     (add2sbuf_indentnl sbuf 1)
+	     )
+	   ( (is_integerbox oiopredef)
+	     (add2sbuf_strconst sbuf "/*iniobpredefnum*/ basilys_globarr[")
+	     (add2sbuf_longdec sbuf (get_int oiopredef))
+	     (add2sbuf_strconst sbuf "] = (void*)&cdat->")
+	     (add2sbuf_string sbuf oname)
+	     (add2sbuf_strconst sbuf ";")
+	     (add2sbuf_indentnl sbuf 1)
+	     )
+	   ( :else
+	     (debug_msg "outcinitfill_objinitobject unexpected oiopredef" oiopredef (the_callcount))
+	     (assert_msg "outcinitfill_objinitobject unexpected oiopredef" ())
+	     )))
+      (add2sbuf_strconst sbuf " cdat->")
+      (add2sbuf_string sbuf oname)
+      (add2sbuf_strconst sbuf ".obj_class = ")
+      (output_c_code odiscr (the_null) sbuf 1)
+      (add2sbuf_strconst sbuf ";")
+      (add2sbuf_indentnl sbuf 1)
+      (add2sbuf_strconst sbuf " cdat->")
+      (add2sbuf_string sbuf oname)
+      (add2sbuf_strconst sbuf ".obj_hash = ")
+      (add2sbuf_longdec sbuf (get_int odhash))
+      (add2sbuf_strconst sbuf ";")
+      (add2sbuf_indentnl sbuf 1)
+      (add2sbuf_strconst sbuf " cdat->")
+      (add2sbuf_string sbuf oname)
+      (add2sbuf_strconst sbuf ".obj_len = ")
+      (add2sbuf_longdec sbuf (multiple_length odslots))
+      (add2sbuf_strconst sbuf ";")
+      (add2sbuf_indentnl sbuf 1)
+      (add2sbuf_strconst sbuf " cdat->")
+      (add2sbuf_string sbuf oname)
+      (add2sbuf_strconst sbuf ".obj_vartab = ")
+      (add2sbuf_strconst sbuf " cdat->")
+      (add2sbuf_string sbuf oname)
+      (add2sbuf_strconst sbuf ".obj__tabfields;")
+      (add2sbuf_indentnl sbuf 1)
+      ;; output the fill
+      )
+    )
+ )
+(install_method class_objinitobject output_c_initfill outcinitfill_objinitobject)
+
+;;; initial multiple - see BASILYS_MULTIPLE_STRUCT in basilys.h
+(defclass class_objinitmultiple
+  :super class_objinitelem
+  :fields (
+))
+(defun outdeclinit_objinitmultiple (recv sbuf)
+  (add2sbuf_strconst sbuf " struct BASILYS_MULTIPLE_STRUCT(")
+  (add2sbuf_longdec sbuf (get_int recv))
+  (add2sbuf_strconst sbuf ") ")
+  (add2sbuf_string sbuf (unsafe_get_field :named_name recv))
+  (add2sbuf_strconst sbuf ";")
+)
+(install_method class_objinitmultiple output_c_declinit outdeclinit_objinitmultiple)
+
+
+(defun outcinitfill_objinitmultiple (recv sbuf)
+  (assert_msg "outcinitfill_objinitmultiple check recv" (is_a recv class_objinitmultiple))
+  (debug_msg "outcinitfill_objinitmultiple recv" recv (the_callcount))
+  (let ( (cnam (unsafe_get_field :oie_cname recv)) 
+	 (olocvar (unsafe_get_field :oie_locvar recv))
+	 )
+    (add2sbuf_strconst sbuf "/*inimult ")
+    (add2sbuf_string sbuf cnam)
+    (add2sbuf_strconst sbuf "*/")
+    (add2sbuf_indentnl sbuf 1)
+    (if olocvar
+	(progn
+	  (add2sbuf_strconst sbuf "/*inimulocvar*/ ")
+	  (output_c_code olocvar (the_null) sbuf 1)
+	  (add2sbuf_strconst sbuf " = (void*)&cdat->")
+	  (add2sbuf_string sbuf cnam)
+	  (add2sbuf_strconst sbuf ";")
+	  (add2sbuf_indentnl sbuf 1)
+	  ))
+    (add2sbuf_strconst sbuf " cdat->")
+    (add2sbuf_string sbuf cnam)
+    (add2sbuf_strconst sbuf ".discr = ")
+    (output_c_code (unsafe_get_field :oie_discr recv) (the_null) sbuf 1)
+    (add2sbuf_strconst sbuf ";")
+    (add2sbuf_indentnl sbuf 1)
+    (add2sbuf_strconst sbuf " cdat->")
+    (add2sbuf_string sbuf cnam)
+    (add2sbuf_strconst sbuf ".nbval = ")
+    (add2sbuf_longdec sbuf (get_int recv))
+    (add2sbuf_strconst sbuf ";")
+    ))
+(install_method class_objinitmultiple output_c_initfill outcinitfill_objinitmultiple)
+
+;;; initial closure - see BASILYS_CLOSURE_STRUCT in basilys.h
+(defclass class_objinitclosure 
+  :super  class_objinitelem
+  :fields (
+))
+(defun outdeclinit_objinitclosure (recv sbuf)
+  (add2sbuf_strconst sbuf " struct BASILYS_CLOSURE_STRUCT(")
+  (add2sbuf_longdec sbuf (get_int recv))
+  (add2sbuf_strconst sbuf ") ")
+  (add2sbuf_string sbuf (unsafe_get_field :oie_cname recv))
+  (add2sbuf_strconst sbuf ";")
+)
+(install_method class_objinitclosure output_c_declinit outdeclinit_objinitclosure)
+
+(defun outcinitfill_objinitclosure (recv sbuf)
+  (assert_msg "outcinitfill_objinitclosure check recv" (is_a recv class_objinitclosure))
+  (debug_msg "outcinitfill_objinitclosure recv" recv (the_callcount))
+  (let ( (cnam (unsafe_get_field :oie_cname recv)) 
+	 (olocvar (unsafe_get_field :oie_locvar recv))
+	 )
+    (add2sbuf_strconst sbuf "/*iniclos ")
+    (add2sbuf_string sbuf cnam)
+    (add2sbuf_strconst sbuf "*/")
+    (add2sbuf_indentnl sbuf 1)
+    (if olocvar
+	(progn
+	  (add2sbuf_strconst sbuf "/*inicloslocvar*/ ")
+	  (output_c_code olocvar (the_null) sbuf 1)
+	  (add2sbuf_strconst sbuf " = (void*)&cdat->")
+	  (add2sbuf_string sbuf cnam)
+	  (add2sbuf_strconst sbuf ";")
+	  (add2sbuf_indentnl sbuf 1)
+	  ))
+    (add2sbuf_strconst sbuf " cdat->")
+    (add2sbuf_string sbuf cnam)
+    (add2sbuf_strconst sbuf ".discr = ")
+    (output_c_code (unsafe_get_field :oie_discr recv) (the_null) sbuf 1)
+    (add2sbuf_strconst sbuf ";")
+    (add2sbuf_indentnl sbuf 1)
+    (add2sbuf_strconst sbuf " cdat->")
+    (add2sbuf_string sbuf cnam)
+    (add2sbuf_strconst sbuf ".nbval = ")
+    (add2sbuf_longdec sbuf (get_int recv))
+    (add2sbuf_strconst sbuf ";")
+    (add2sbuf_indentnl sbuf 1)
+    ))
+(install_method class_objinitclosure output_c_initfill outcinitfill_objinitclosure)
+
+
+;;; initial routine - see  BASILYS_ROUTINE_STRUCT in basilys.h
+(defclass class_objinitroutine
+  :super class_objinitelem
+  :fields (
+	   oir_procroutine		;the procroutine associated
+))
+(defun outdeclinit_objinitroutine (recv sbuf)
+  (add2sbuf_strconst sbuf " struct BASILYS_ROUTINE_STRUCT(")
+  (add2sbuf_longdec sbuf (get_int recv))
+  (add2sbuf_strconst sbuf ") ")
+  (add2sbuf_string sbuf (unsafe_get_field :oie_cname recv))
+  (add2sbuf_strconst sbuf ";")
+)
+(install_method class_objinitroutine output_c_declinit outdeclinit_objinitroutine)
+
+
+(defun outcinitfill_objinitroutine (recv sbuf)
+  (assert_msg "outcinitfill_objinitroutine check recv" (is_a recv class_objinitroutine))
+  (debug_msg "outcinitfill_objinitroutine recv" recv (the_callcount))
+  (let ( (cnam (unsafe_get_field :oie_cname recv)) 
+	 (ipro (unsafe_get_field :oir_procroutine recv))
+	 (olocvar (unsafe_get_field :oie_locvar recv))
+	 (ndatr (unsafe_get_field :oie_data recv))
+	 )
+    (add2sbuf_strconst sbuf "/*inirout ")
+    (add2sbuf_string sbuf cnam)
+    (add2sbuf_strconst sbuf "*/")
+    (add2sbuf_indentnl sbuf 1)
+    (if olocvar
+	(progn
+	  (add2sbuf_strconst sbuf "/*iniroutlocvar*/ ")
+	  (output_c_code olocvar (the_null) sbuf 1)
+	  (add2sbuf_strconst sbuf " = (void*)&cdat->")
+	  (add2sbuf_string sbuf cnam)
+	  (add2sbuf_strconst sbuf ";")
+	  (add2sbuf_indentnl sbuf 1)
+	  ))
+    (add2sbuf_strconst sbuf " cdat->")
+    (add2sbuf_string sbuf cnam)
+    (add2sbuf_strconst sbuf ".discr = ")
+    (output_c_code (unsafe_get_field :oie_discr recv) (the_null) sbuf 1)
+    (add2sbuf_strconst sbuf ";")
+    (add2sbuf_indentnl sbuf 1)
+    (add2sbuf_strconst sbuf " strncpy(cdat->")
+    (add2sbuf_string sbuf cnam)
+    (add2sbuf_strconst sbuf ".routdescr, \"")
+    (if (is_a ndatr class_nrep_dataroutine)
+	(let ( (dnam (unsafe_get_field :ndata_name ndatr))
+	       (dpro (unsafe_get_field :ndrou_proc ndatr))
+	       )
+	  (debug_msg "outcinitfill_objinitroutine ndatr" ndatr (the_callcount))
+	  (debug_msg "outcinitfill_objinitroutine dpro" dpro (the_callcount))
+	  (if (is_a dnam class_named)
+	      (add2sbuf_cencstring sbuf (unsafe_get_field :named_name dnam)))
+	  (if (is_a dpro class_nrep_routproc)
+	      (let (  (dloc (unsafe_get_field :nrep_loc dpro))
+		      (locfil (mixint_val dloc)) )
+		(add2sbuf_strconst sbuf " @")
+		(add2sbuf_cencstring sbuf locfil)
+		(add2sbuf_strconst sbuf ":")
+		(add2sbuf_longdec sbuf (get_int dloc))
+		)
+	    )
+	  )
+      (add2sbuf_cencstring sbuf cnam))
+    (add2sbuf_strconst sbuf "\",  BASILYS_ROUTDESCR_LEN - 1);")
+    (add2sbuf_indentnl sbuf 1)
+    (add2sbuf_strconst  sbuf " cdat->")
+    (add2sbuf_string sbuf cnam)
+    (add2sbuf_strconst sbuf ".nbval = ")
+    (add2sbuf_longdec sbuf (get_int recv))
+    (add2sbuf_strconst sbuf ";")
+    (add2sbuf_indentnl sbuf 1)
+    (if ipro
+	(progn
+	  (debug_msg "outcinitfill_objinitroutine ipro" ipro (the_callcount))
+	  (assert_msg "check ipro" (is_a ipro class_named))
+	  (add2sbuf_strconst sbuf "*(basilysroutfun_t **) (cdat->")
+	  (add2sbuf_string sbuf cnam)
+	  (add2sbuf_strconst sbuf ".routaddr) = ")
+	  (add2sbuf_string sbuf (unsafe_get_field :named_name ipro))
+	  (add2sbuf_strconst sbuf ";")
+	  (add2sbuf_indentnl sbuf 1)
+	  )
+      (progn
+	(debug_msg "outcinitfill_objinitroutine (noipro) recv" recv (the_callcount))
+	(add2sbuf_strconst sbuf "#warning no procedure in objinitroutine ")
+	(add2sbuf_string sbuf cnam)
+	(add2sbuf_indentnl sbuf 1)
+	)
+      )
+    ))
+(install_method class_objinitroutine output_c_initfill outcinitfill_objinitroutine)
+
+;;; initial string - see BASILYS_STRING_STRUCT in basilys.h
+(defclass class_objinitstring
+  :super class_objinitelem
+  :fields (
+))
+(defun outdeclinit_objinitstring (recv sbuf)
+  (add2sbuf_strconst sbuf " struct BASILYS_STRING_STRUCT(")
+  (add2sbuf_longdec sbuf (get_int recv))
+  (add2sbuf_strconst sbuf ") ")
+  (add2sbuf_string sbuf (unsafe_get_field :named_name recv))
+  (add2sbuf_strconst sbuf ";")
+)
+(install_method class_objinitstring output_c_declinit outdeclinit_objinitstring)
+
+
+(defun outcinitfill_objinitstring (recv sbuf)
+  (assert_msg "outcinitfill_objinitstring check recv" (is_a recv class_objinitstring))
+  (debug_msg "outcinitfill_objinitstring recv" recv (the_callcount))
+  (let ( (cnam (unsafe_get_field :oie_cname recv)) 
+	 (olocvar (unsafe_get_field :oie_locvar recv))
+	 )
+    (add2sbuf_strconst sbuf "/*inistring ")
+    (add2sbuf_string sbuf cnam)
+    (add2sbuf_strconst sbuf "*/")
+    (add2sbuf_indentnl sbuf 1)
+    (if olocvar
+	(progn
+	  (add2sbuf_strconst sbuf "/*inistrlocvar*/ ")
+	  (output_c_code olocvar (the_null) sbuf 1)
+	  (add2sbuf_strconst sbuf " = (void*)&cdat->")
+	  (add2sbuf_string sbuf cnam)
+	  (add2sbuf_strconst sbuf ";")
+	  (add2sbuf_indentnl sbuf 1)
+	  ))
+    (add2sbuf_strconst sbuf " cdat->")
+    (add2sbuf_string sbuf cnam)
+    (add2sbuf_strconst sbuf ".discr = ")
+    (output_c_code (unsafe_get_field :oie_discr recv) (the_null) sbuf 1)
+    (add2sbuf_strconst sbuf ";")
+    (add2sbuf_indentnl sbuf 1)
+    (add2sbuf_strconst sbuf " strcpy(cdat->")
+    (add2sbuf_string sbuf cnam)
+    (add2sbuf_strconst sbuf ".val, \"")
+    (add2sbuf_cencstring sbuf (unsafe_get_field :oie_data recv))
+    (add2sbuf_strconst sbuf "\");")
+    (add2sbuf_indentnl sbuf 1)
+    ))
+(install_method class_objinitstring output_c_initfill outcinitfill_objinitstring)
+
+;; expanded value
+(defclass class_objexpv
+  :super class_objvalue
+  :fields (obx_cont
+))
+
+;;;; instructions
+(defclass class_objinstr
+  :super class_objcode
+  :fields (obi_loc			;src location
+))
+
+;;; compute instruction
+(defclass class_objcompute
+  :super class_objinstr
+  :fields (obcpt_dest			;destination list
+	   obcpt_expr			;expression list
+))
+
+;; get argument instruction
+(defclass class_objgetarg
+  :super class_objinstr
+  :fields (obarg_obloc			;objlocation
+	   obarg_bind			;formal binding
+))
+
+
+;; put extra result instruction
+(defclass class_objputxtraresult
+  :super class_objinstr
+  :fields (obxres_rank 			;boxed rank
+	   obxres_obloc			;objlocation
+))
+
+;; final return
+(defclass class_objfinalreturn
+  :super class_objinstr
+  :fields (				;no argument
+))
+
+;; clear instruction
+(defclass class_objclear
+  :super class_objinstr
+  :fields (oclr_vloc			;varlocation to clear
+))
+
+;; block instruction
+(defclass class_objblock
+  :super class_objinstr
+  :fields ( oblo_bodyl			;body list
+	    oblo_epil			;epilogue list
+))
+
+;; looping block
+(defclass class_objloop
+  :super class_objblock		 ;the body is looped, not the epilogue
+  :fields (obloop_label		 ;cloned symbol
+	   obloop_resv		 ;the result of the loop
+))
+
+;; exit a loop (with a single body)
+(defclass class_objexit
+  :super class_objinstr
+  :fields (obexit_label			;cloned symbol for goto destination
+	   obexit_prolog		;single instruction prolog
+))
+
+;; conditional instruction
+(defclass class_objcond
+  :super class_objinstr
+  :fields (obcond_test
+	   obcond_then
+	   obcond_else
+))
+
+;;; apply instruction
+(defclass class_objapply
+  :super class_objinstr
+  :fields (obapp_dest			;destination list
+	   obapp_clos			;closure to be applied
+	   obapp_args			;argument tuple
+))
+
+;; raw object allocation instruction
+(defclass class_objrawallocobj
+  :super class_objinstr
+  :fields (obrallobj_class		;the class data
+	   obrallobj_len		;the boxed integer length
+	   obrallobj_dest			;the list of destinations
+))
+
+
+;; new closure allocation
+(defclass class_objnewclosure
+  :super class_objinstr
+  :fields (obnclo_discr		     ;the discriminant
+	   obnclo_rout		     ;the routine
+	   obnclo_len		     ;the boxed integer length
+	   obnclo_dest		     ;the list of destinations
+))
+
+;; put a component inside a tuple
+(defclass class_objputuple
+  :super class_objinstr
+  :fields (oputu_tupled			;the tuple data
+	   oputu_offset			;numerical offset
+	   oputu_value			;the new value
+))
+
+;; put a slot inside an object
+(defclass class_objputslot
+  :super class_objinstr
+  :fields ( oslot_odata			;the object data to put
+	    oslot_offset		;numerical offset
+	    oslot_value			;the new value
+))
+
+;; put the routine inside a closure
+(defclass class_objputclosurout
+  :super class_objinstr
+  :fields (opclor_clos			;the closure data
+	   opclor_rout			;the routine data
+))
+
+;; put a closed value inside a closure
+(defclass class_objputclosedv
+  :super class_objinstr
+  :fields (opclov_clos			;the closure data or local
+	   opclov_off 			;the boxed offset
+	   opclov_cval			;the closed value
+))
+
+;; put a constant value inside a routine
+(defclass class_objputroutconst
+  :super class_objinstr
+  :fields (oprconst_rout	 ;the routine data
+	   oprconst_off		 ;the boxed offset
+	   oprconst_cval	 ;the constant value
+))
+
+;; touch a value, with a tiny comment
+(defclass class_objtouch
+  :super class_objinstr
+  :fields (otouch_val
+	   otouch_comment
+))
+
+;; set a predef
+(defclass class_objsetpredef
+ :super class_objinstr
+ :fields ( ospr_object			;the object 
+	   ospr_predef			;its predef rank
+))
+
+
+;;; routines
+(defclass class_routineobj
+  :super class_named
+  :fields (obrout_proc			;the associated procedure
+	   obrout_body			;the body (a list)
+	   obrout_nbval			;the boxed number of value pointers
+	   obrout_nblong		;the boxed number of longs
+	   obrout_others		;the list of other (nonvalue, nonlongs) locals
+	   obrout_retval		;the main return value
+))
+
+;; procedure routine
+(defclass class_procroutineobj
+  :super class_routineobj
+  :fields (oprout_getargs		;the get arguments tuple of instructions
+))
+
+;; initial routine
+(defclass class_initialroutineobj
+  :super class_routineobj
+  :fields (
+	   oirout_data			;the tuple of initial data
+	   oirout_fill			;the fill of the data (a list of instr)
+))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; notes about code generation
+;;;
+;;; in addition of the code structure generated by cold-basilys we
+;;; need to be able to import values (hence bindings) from a start
+;;; environment which is the only argument given to the generated
+;;; start routine of the module
+
+(defun outpucod_anydiscr (any declbuf implbuf :long depth)
+  (debug_msg "outpucod_anydiscr any" any (the_callcount))
+  (assert_msg "@@ outpucod_anydiscr not able to output" ())
+)
+(install_method discr_anyrecv output_c_code outpucod_anydiscr)
+
+(defun outpucod_null (nul declbuf implbuf :long depth)
+  (add2sbuf_strconst implbuf "NULL")
+)
+(install_method discr_nullrecv output_c_code outpucod_null)
+
+;;; catchall for outputting any stuff
+(defun outpucod_root (anyr declbuf implbuf :long depth)
+  (debug_msg "outpucod_root anyr" anyr (the_callcount))
+  (assert_msg "@@ outpucod_root not able to output" ())
+)
+(install_method class_root output_c_code outpucod_root)
+
+
+;;; output the code for declaring and initializing the current frame 
+(defun output_curframe_init (rou implbuf)
+  (debug_msg "output_curframe_init rou" rou (the_callcount))
+  (let (
+	(obody (unsafe_get_field :obrout_body rou))
+	(onbval (unsafe_get_field :obrout_nbval rou))
+	(onblong (unsafe_get_field :obrout_nblong rou))
+	(:long nbval (get_int onbval))
+	(:long nblong (get_int onblong))
+	(others (unsafe_get_field :obrout_others rou))
+	)
+    ;; output call counter for debugging
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf "#if ENABLE_CHECKING")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf " static long call_counter__;")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf " long thiscallcounter__ ATTRIBUTE_UNUSED = ++ call_counter__;")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf "#define callcount thiscallcounter__")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf "#else")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf "#define callcount 0L")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf "#endif")
+    ;; output the current frame
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf " struct { unsigned nbvar;")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf "  struct basilysclosure_st *clos;")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf "  struct excepth_basilys_st *exh;")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf "  struct callframe_basilys_st *prev;")
+    (add2sbuf_indentnl implbuf 0)
+    (if (>i nbval 0) 
+	(progn
+	  (add2sbuf_strconst implbuf "  void* varptr[")
+	  (add2sbuf_longdec implbuf nbval)
+	  (add2sbuf_strconst implbuf "];")
+	  (add2sbuf_indentnl implbuf 0))
+      (progn
+	(add2sbuf_strconst implbuf "/*no varptr*/")
+	(add2sbuf_indentnl implbuf 0)))
+    (if (>i nblong 0)
+	(progn
+	  (add2sbuf_strconst implbuf "  long varnum[")
+	  (add2sbuf_longdec implbuf nblong)
+	  (add2sbuf_strconst implbuf "];")
+	  (add2sbuf_indentnl implbuf 0))
+      (progn
+	(add2sbuf_strconst implbuf "/*no varnum*/")
+	(add2sbuf_indentnl implbuf 0))
+	)
+    (if others 
+	(progn
+	  (debug_msg "output_curframe_init others" others (the_callcount))
+	  (assert_msg "output_curframe_init @@ handling of others not implemented" ())
+	  ))
+    (add2sbuf_strconst implbuf "  long _spare_; } curfram__ = {")
+    (add2sbuf_longdec implbuf nbval)
+    (add2sbuf_strconst implbuf ", ")
+    (add2sbuf_strconst implbuf " (struct basilysclosure_st *)0, ")
+    (add2sbuf_strconst implbuf " (struct excepth_basilys_st *)0, ")
+    (add2sbuf_strconst implbuf " (struct callframe_basilys_st *) 0, ")
+    (if (>i nbval 0) 
+	(let ( (:long ix 0) )
+	  (add2sbuf_indentnl implbuf 0)
+	  (add2sbuf_strconst implbuf " /*ptrvars*/{")
+	  (forever ptrloop
+		   (if (>=i ix nbval) (exit ptrloop))
+		   (if (>i ix 0) (add2sbuf_strconst implbuf ","))
+		   (if (==i 0 (%iraw ix 8)) 
+		       (add2sbuf_indentnl implbuf 2))
+		   (add2sbuf_strconst implbuf " (void*)0")
+		   (setq ix (+i ix 1))
+		   )
+	  (add2sbuf_strconst implbuf "},") ;
+	  ))
+    (if (>i nblong 0) 
+	(let ( (:long ix 0) )
+	  (add2sbuf_indentnl implbuf 0)
+	  (add2sbuf_strconst implbuf " /*numvars*/{")
+	  (forever ptrloop
+		   (if (>=i ix nblong) (exit ptrloop))
+		   (if (>i ix 0) (add2sbuf_strconst implbuf ","))
+		   (if (==i 0 (%iraw ix 8)) 
+		       (add2sbuf_indentnl implbuf 2))
+		   (add2sbuf_strconst implbuf " 0L")
+		   (setq ix (+i ix 1))
+		   )
+	  (add2sbuf_strconst implbuf "},") ;
+	  ))
+    (assert_msg "output_curframe_init @@ initialization of others not implemented" (null others))
+    (add2sbuf_strconst implbuf " 0L };")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf " curfram__.prev = (void*) basilys_topframe;")
+    (add2sbuf_indentnl implbuf 0)
+    (if  (is_a rou class_initialroutineobj)
+	(progn
+	  (add2sbuf_strconst implbuf " curfram__.clos = NULL /*since initroutine*/;")
+	  (add2sbuf_indentnl implbuf 0)
+	  )
+	(progn
+	  (add2sbuf_strconst implbuf " curfram__.clos = closp_;")
+	  (add2sbuf_indentnl implbuf 0)
+	  ))
+    (add2sbuf_strconst implbuf " basilys_topframe = (void*) &curfram__;")
+    (add2sbuf_indentnl implbuf 0)
+    ))
+
+;;; output code for a procroutine
+(defun outpucod_procroutine (prou declbuf implbuf :long depth)
+  (assert_msg "check prou" (is_a prou class_procroutineobj))
+  (let ( (onam (unsafe_get_field :named_name prou)) 
+	 (obody (unsafe_get_field :obrout_body prou))
+	 (onbval (unsafe_get_field :obrout_nbval prou))
+	 (onblong (unsafe_get_field :obrout_nblong prou))
+	 (:long nbval (get_int onbval))
+	 (:long nblong (get_int onblong))
+	 (others (unsafe_get_field :obrout_others prou))
+	 (ogargs (unsafe_get_field :oprout_getargs prou))
+	 (oretval (unsafe_get_field :obrout_retval prou))
+	 )
+    (debug_msg "outpucod_procroutine prou" prou (the_callcount))
+    ;; output the declaration
+    (add2sbuf_indentnl declbuf 0)
+    (add2sbuf_strconst declbuf "static basilys_ptr_t ")
+    (add2sbuf_string declbuf onam)
+    (add2sbuf_strconst declbuf "(basilysclosure_ptr_t closp_,")
+    (add2sbuf_strconst declbuf " basilys_ptr_t firstargp_,")
+    (add2sbuf_strconst declbuf " const char xargdescr_[],")
+    (add2sbuf_strconst declbuf " union basilysparam_un *xargtab_,")
+    (add2sbuf_strconst declbuf " const char xresdescr_[],")
+    (add2sbuf_strconst declbuf " union basilysparam_un *xrestab_);")
+    (add2sbuf_indentnl declbuf 0)
+    ;; output the implementation
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf "static basilys_ptr_t ")
+    (add2sbuf_string implbuf onam)
+    (add2sbuf_strconst implbuf "(basilysclosure_ptr_t closp_,")
+    (add2sbuf_strconst implbuf " basilys_ptr_t firstargp_,")
+    (add2sbuf_strconst implbuf " const char xargdescr_[],")
+    (add2sbuf_strconst implbuf " union basilysparam_un *xargtab_,")
+    (add2sbuf_strconst implbuf " const char xresdescr_[],")
+    (add2sbuf_strconst implbuf " union basilysparam_un *xrestab_) {")
+    (output_curframe_init prou implbuf)
+    ;; output the argument getting
+    (add2sbuf_strconst implbuf "/*getargs*/")
+    (add2sbuf_indentnl implbuf 0)
+    (debug_msg "outpucod_procroutine output ogargs" ogargs (the_callcount))
+    (assert_msg "check ogargs" (is_multiple ogargs))
+    (multiple_iterate
+     ogargs
+     (lambda (curget :long curank) 
+       (add2sbuf_indentnl implbuf 1)
+       (add2sbuf_strconst implbuf "/*getarg#")
+       (add2sbuf_longdec implbuf curank)
+       (add2sbuf_strconst implbuf "*/")
+       (add2sbuf_indentnl implbuf 1)
+       (output_c_code curget declbuf implbuf 1)
+       ogargs
+       ))
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf " goto lab_endgetargs;")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf "lab_endgetargs:;")
+    (add2sbuf_indentnl implbuf 0)
+    ;; output the body
+    (debug_msg "outpucod_procroutine output obody" obody (the_callcount))
+    (assert_msg "check obody" (is_list obody))
+    (add2sbuf_strconst implbuf "/*body*/")
+    (add2sbuf_indentnl implbuf 0)
+    (list_iterate 
+     obody
+     (lambda (curbody)
+       (output_c_code curbody declbuf implbuf 0)
+       (add2sbuf_indentnl implbuf 0)
+       obody))
+    ;; end of implementation
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf " goto labend_rout;")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf "labend_rout:  basilys_topframe = (void *) curfram__.prev;")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf " return ")
+    (if oretval 
+	(output_c_code oretval declbuf implbuf 1)
+      (add2sbuf_strconst implbuf "/*noretval*/ NULL"))
+    (add2sbuf_strconst implbuf ";")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf "#undef callcount")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf "} /*end ")
+    (add2sbuf_string implbuf onam)
+    (add2sbuf_strconst implbuf "*/")
+    (add2sbuf_indentnl implbuf 0)
+    ))
+(install_method class_procroutineobj output_c_code outpucod_procroutine)
+
+
+;; output code for the initial routine
+(defun outpucod_initialroutine (pini declbuf implbuf :long depth)
+  (assert_msg "check pini" (is_a pini class_initialroutineobj))
+  (add2sbuf_indentnl declbuf 0)
+  (add2sbuf_strconst declbuf "void* start_module_basilys(void*);")
+  (add2sbuf_indentnl declbuf 0)
+  (add2sbuf_indentnl implbuf 0)
+  (add2sbuf_strconst implbuf "void* start_module_basilys(void* modatap_) {")
+  (add2sbuf_indentnl implbuf 0)
+  (debug_msg "outpucod_initialroutine pini" pini (the_callcount))
+  ;; generate the initial data structure
+  (let ( 
+	(idatup (unsafe_get_field :oirout_data pini)) 
+	(irfill (unsafe_get_field :oirout_fill pini))
+	(oretval (unsafe_get_field :obrout_retval pini))
+	) 
+    (debug_msg "outpucod_initialroutine start idatup" idatup (the_callcount))
+    (debug_msg "outpucod_initialroutine start irfill" irfill (the_callcount))
+    (add2sbuf_indentnl implbuf 1)
+    (add2sbuf_strconst implbuf "struct cdata_st {")
+    (multiple_iterate 
+     idatup
+     (lambda (curdat :long curk) 
+       (debug_msg "outpucod_initialroutine curdat" curdat (the_callcount))
+       (add2sbuf_indentnl implbuf 1)
+       (output_c_declinit curdat implbuf)
+       idatup
+       )
+     )
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf " long spare_;")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf "} *cdat = NULL;")
+    (add2sbuf_indentnl implbuf 1)
+    ;; generate the initial frame
+    (output_curframe_init pini implbuf)
+    ;; generate the allocation of cdat
+    (add2sbuf_strconst implbuf " cdat = basilysgc_allocate(sizeof(*cdat),0);")
+    (add2sbuf_indentnl implbuf 1)
+    (add2sbuf_strconst implbuf " basilys_prohibit_garbcoll = TRUE;")
+    (add2sbuf_indentnl implbuf 1)
+;;; generate the initial filling of cdat
+    (multiple_iterate 
+     idatup
+     (lambda (curfil :long curk) 
+       (debug_msg "outpucod_initialroutine curfil" curfil (the_callcount))
+       (add2sbuf_indentnl implbuf 1)
+       (output_c_initfill curfil implbuf)
+       idatup
+       )
+     )
+;;; initialize the variables
+    (debug_msg "outpucod_initialroutine irfill" irfill)
+    (list_iterate 
+     irfill
+     (lambda (curifil)
+       (debug_msg "outpucod_initialroutine curifil" curifil (the_callcount))
+       irfill))
+;;; clear the cdat for safety and renable GC
+    (add2sbuf_strconst implbuf " cdat = NULL;")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf " basilys_prohibit_garbcoll = FALSE;")
+    (add2sbuf_indentnl implbuf 0)
+;;; output the body
+    (add2sbuf_strconst implbuf "/*initroutbody*/")
+    (add2sbuf_indentnl implbuf 0)
+    (let ( (ibody (unsafe_get_field :obrout_body pini)) 
+	   )
+      (debug_msg "outpucod_initialroutine ibody" ibody)
+      (list_iterate
+       ibody
+       (lambda (curbody)
+	 (debug_msg "outpucod_initialroutine curbody" curbody (the_callcount))
+	 (output_c_code curbody declbuf implbuf 1)
+	 ibody)
+      ))
+    ;; end of implementation
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf " goto labend_rout;")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf "labend_rout:  basilys_topframe = (void *) curfram__.prev;")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf " return ")
+    (if oretval 
+	(output_c_code oretval declbuf implbuf 1)
+      (add2sbuf_strconst implbuf "/*noretval*/ NULL"))
+    (add2sbuf_strconst implbuf ";")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf "#undef callcount")
+    (add2sbuf_indentnl implbuf 0)
+    (add2sbuf_strconst implbuf "} /* end start_module_basilys */")
+    (add2sbuf_indentnl implbuf 0))
+     
+  )
+(install_method class_initialroutineobj output_c_code outpucod_initialroutine)
+
+
+
+;; output code for argument getter
+(defun outpucod_getarg (garg declbuf implbuf :long depth)
+  (assert_msg "check garg" (is_a garg class_objgetarg))
+  (debug_msg "outpucod_getarg garg" garg (the_callcount))
+  (let ( (oloc (unsafe_get_field :obarg_obloc garg))
+	 (obind (unsafe_get_field :obarg_bind garg))
+	 (:long rkbind (get_int obind))
+	 (ctybind (unsafe_get_field :fbind_type obind))
+	 )
+    (assert_msg "check obind" (is_a obind class_formal_binding))
+    (assert_msg "check oloc" (is_a oloc class_objlocv))
+    (assert_msg "check ctybind" (is_a ctybind class_ctype))
+    (if (==i rkbind 0)
+	(progn
+	  (assert_msg "check ctybind first" (== ctybind ctype_value))
+	  (output_c_code oloc declbuf implbuf depth)
+	  (add2sbuf_strconst implbuf " = firstargp_;")
+	  (add2sbuf_indentnl implbuf depth)
+	  )
+      (let (
+	    ;; use the ctype_parchar ctype_argfield
+	    (parc (unsafe_get_field :ctype_parchar ctybind))
+	    (argf (unsafe_get_field :ctype_argfield ctybind)) 
+	    )
+	(if (not (is_string parc)) 
+	    (error_strv () "impossible argument ctype" 
+			(unsafe_get_field :named_name ctybind)))
+	(add2sbuf_strconst implbuf "if (xargdescr_[")
+	(add2sbuf_longdec implbuf (-i rkbind 1))
+	(add2sbuf_strconst implbuf "] != ")
+	(add2sbuf_string implbuf parc)
+	(add2sbuf_strconst implbuf ") goto lab_endgetargs;")	
+	(add2sbuf_indentnl implbuf depth)
+	(if (== ctybind ctype_value)
+	    (progn
+	      (output_c_code oloc declbuf implbuf depth)
+	      (add2sbuf_strconst implbuf " = *(xargtab_[")
+	      (add2sbuf_longdec implbuf (-i rkbind 1))
+	      (add2sbuf_strconst implbuf "].bp_aptr);")	
+	      )
+	  (progn
+	    (output_c_code oloc declbuf implbuf depth)
+	    (add2sbuf_strconst implbuf " = xargtab_[")
+	    (add2sbuf_longdec implbuf (-i rkbind 1))
+	    (add2sbuf_strconst implbuf "].")
+	    (add2sbuf_string implbuf argf)
+	    (add2sbuf_strconst implbuf ";")
+	    )
+	  )
+	(add2sbuf_indentnl implbuf depth)
+	))
+    (debug_msg "outpucod_getarg done garg" garg (the_callcount))
+    ))
+(install_method class_objgetarg output_c_code outpucod_getarg)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; output code for objlocv
+(defun outpucod_objlocv (locv declbuf implbuf :long depth)
+  (assert_msg "check locv" (is_a locv class_objlocv))
+  ;; (debug_msg "outpucod_objlocv locv" locv (the_callcount))
+  (let ( 
+	(ltyp (unsafe_get_field :obv_type locv))
+	(loff (unsafe_get_field :obl_off locv))
+	(lcnam (unsafe_get_field :obl_cname locv))
+	)
+    (cond 
+     ( (== ltyp ctype_value)
+       (add2sbuf_strconst implbuf "/*lptr:")
+       (add2sbuf_string implbuf lcnam)
+       (add2sbuf_strconst implbuf "*/curfram__.varptr[")
+       (add2sbuf_longdec implbuf (get_int loff))
+       (add2sbuf_strconst implbuf "]") )
+     ( (== ltyp ctype_long)
+       (add2sbuf_strconst implbuf "/*llng:")
+       (add2sbuf_string implbuf lcnam)
+       (add2sbuf_strconst implbuf "*/curfram__.varnum[")
+       (add2sbuf_longdec implbuf (get_int loff))
+       (add2sbuf_strconst implbuf "]") )
+     (:else
+      (add2sbuf_strconst implbuf "/*lother*/curfram__.")
+      (add2sbuf_string implbuf lcnam)))
+    )
+  )
+(install_method class_objlocv output_c_code outpucod_objlocv)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; output code for object closed occurrence
+(defun outpucod_objcloccv (occv  declbuf implbuf :long depth)
+  (assert_msg "check occv" (is_a occv class_objcloccv))
+  (let ( (ooff (unsafe_get_field :obc_off occv))
+	 (onam (unsafe_get_field :obc_name occv)) )
+    (assert_msg "check valueness of closed occurrence" 
+		(== (unsafe_get_field :obv_type occv) ctype_value))
+    (add2sbuf_strconst implbuf "(/*~")
+    (add2sbuf_string implbuf onam)
+    (add2sbuf_strconst implbuf "*/ curfram__.clos->tabval[")
+    (add2sbuf_longdec implbuf (get_int ooff))
+    (add2sbuf_strconst implbuf "])")
+))
+(install_method class_objcloccv output_c_code outpucod_objcloccv)
+
+
+;;;;;;;;;;;;;;;;
+;; output code for object const [closed] occurrence
+(defun outpucod_objconstv (ocnstv  declbuf implbuf :long depth)
+  (assert_msg "check ocnstv" (is_a ocnstv class_objconstv))
+  (debug_msg "outpucod_objconstv ocnstv" ocnstv (the_callcount))
+  (let ( (ooff (unsafe_get_field :obc_off ocnstv))
+	 (onam (unsafe_get_field :obc_name ocnstv)) )
+    (assert_msg "check valueness of const occurrence" 
+		(== (unsafe_get_field :obv_type ocnstv) ctype_value))
+    (add2sbuf_strconst implbuf "(/*!")
+    (add2sbuf_string implbuf onam)
+    (add2sbuf_strconst implbuf "*/ curfram__.clos->rout->tabval[")
+    (add2sbuf_longdec implbuf (get_int ooff))
+    (add2sbuf_strconst implbuf "])")
+))
+(install_method class_objconstv output_c_code outpucod_objconstv)
+
+;;; common code to output a location
+(defun output_location (loc implbuf :long depth)
+  (if (is_mixint loc)
+      (progn
+	(add2sbuf_indentnl implbuf depth)
+	(add2sbuf_strconst implbuf "#line ")
+	(add2sbuf_longdec implbuf (get_int loc))
+	(add2sbuf_strconst implbuf " \"")
+	(add2sbuf_string implbuf (mixint_val loc))
+	(add2sbuf_strconst implbuf "\"")
+	(add2sbuf_indentnl implbuf depth)
+	)))
+
+
+;; output code for objblock
+(defun outpucod_objblock (oblo declbuf implbuf :long depth)
+  (assert_msg "check oblo" (is_a oblo class_objblock))
+  (debug_msg "outpucod_objblock oblo" oblo (the_callcount))
+  (output_location (unsafe_get_field :obi_loc oblo) implbuf depth)
+  (let ( (bodyl (unsafe_get_field :oblo_bodyl oblo))
+	 (epil (unsafe_get_field :oblo_epil oblo)) 
+	 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
+	 )
+    (add2sbuf_strconst implbuf "/*block*/{")
+    (if (is_list bodyl)
+	(progn
+	  (add2sbuf_indentnl implbuf (+i depth 1))
+	  (list_iterate 
+	   bodyl
+	   (lambda (curbody)
+	     (let ( (:long depthp1 (get_int boxdepthp1)) )
+	       (if (is_a curbody class_objinstr)
+		   (progn
+		     (output_c_code curbody declbuf implbuf depthp1)
+		     (add2sbuf_strconst implbuf ";")
+		     (add2sbuf_indentnl implbuf depthp1)))
+	       bodyl)))))
+    (if (is_list epil)
+	(progn
+	  (add2sbuf_strconst implbuf "/*epilog*/")
+	  (add2sbuf_indentnl implbuf (+i depth 1))
+	  (list_iterate
+	   epil
+	   (lambda (curepil)
+	     (let ( (:long depthp1 (get_int boxdepthp1)) )
+	       (if (is_a curepil class_objinstr)
+		   (progn
+		     (output_c_code curepil declbuf implbuf depthp1)
+		     (add2sbuf_strconst implbuf ";")
+		     (add2sbuf_indentnl implbuf depthp1))))
+	     epil))))
+    (add2sbuf_strconst implbuf "}")
+    (add2sbuf_indentnl implbuf depth)
+    )
+  (debug_msg "outpucod_objblock done oblo" oblo (the_callcount))
+  )
+(install_method class_objblock output_c_code outpucod_objblock)
+
+
+;;; add a cname for a cloned identifier into a buffer
+(defun add2sbuf_clonsym (sbuf csy)
+  (assert_msg "check sbuf" (is_strbuf sbuf))
+  (assert_msg "check csy" (is_a csy class_clonedsymbol))
+  (let ( (cnam (unsafe_get_field :named_name csy))
+	 (:long rk (get_int (unsafe_get_field :csym_urank csy))) )
+    (add2sbuf_cident sbuf cnam)
+    (add2sbuf_strconst sbuf "_")
+    (add2sbuf_longdec sbuf rk)
+))
+
+;;; output code for objloop
+(defun outpucod_objloop (oblo declbuf implbuf :long depth)
+  (assert_msg "check oblo" (is_a oblo class_objloop))
+  (debug_msg "outpucod_objloop oblo" oblo (the_callcount))
+  (output_location (unsafe_get_field :obi_loc oblo) implbuf depth)
+  (let ( (bodyl (unsafe_get_field :oblo_bodyl oblo))
+	 (epil (unsafe_get_field :oblo_epil oblo)) 
+	 (lab (unsafe_get_field :obloop_label oblo))
+	 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
+	 )
+    (assert_msg "check lab" (is_a lab class_clonedsymbol))
+    (add2sbuf_strconst implbuf "/*loop*/{ labloop_")
+    (add2sbuf_clonsym implbuf lab)
+    (add2sbuf_strconst implbuf ":;")
+    (if (is_list bodyl)
+	(progn
+	  (add2sbuf_indentnl implbuf (+i depth 1))
+	  (list_iterate 
+	   bodyl
+	   (lambda (curbody)
+	     (let ( (:long depthp1 (get_int boxdepthp1)) )
+	       (output_c_code curbody declbuf implbuf depthp1)
+	       (add2sbuf_strconst implbuf ";")
+	       (add2sbuf_indentnl implbuf depthp1))
+	     bodyl))))
+    (add2sbuf_indentnl implbuf (+i depth 1))
+    (add2sbuf_strconst implbuf " goto labloop_")
+    (add2sbuf_clonsym implbuf lab)
+    (add2sbuf_strconst implbuf ";")
+    (add2sbuf_indentnl implbuf (+i depth 1))
+    (add2sbuf_strconst implbuf " labexit_")
+    (add2sbuf_clonsym implbuf lab)
+    (add2sbuf_strconst implbuf ":;")
+    (if (is_list epil)
+	(progn
+	  (add2sbuf_strconst implbuf "/*loopepilog*/")
+	  (add2sbuf_indentnl implbuf (+i depth 1))
+	  (list_iterate
+	   epil
+	   (lambda (curepil)
+	     (let ( (:long depthp1 (get_int boxdepthp1)) )
+	       (output_c_code curepil declbuf implbuf depthp1)
+	       (add2sbuf_strconst implbuf ";")
+	       (add2sbuf_indentnl implbuf depthp1))
+	     epil))))
+    (add2sbuf_strconst implbuf "}")
+    (add2sbuf_indentnl implbuf depth)
+    )
+  (debug_msg "outpucod_objloop done oblo" oblo (the_callcount))
+  )
+(install_method class_objloop output_c_code outpucod_objloop)
+
+
+;;; output code for objexit
+(defun outpucod_objexit (obxi declbuf implbuf :long depth)
+  (assert_msg "check obxi" (is_a obxi class_objexit))
+  (debug_msg "outpucod_objexit obxi" obxi (the_callcount))
+  (output_location (unsafe_get_field :obi_loc obxi) implbuf depth)
+  (let ( (olab (unsafe_get_field :obexit_label obxi))
+	 (oprolog (unsafe_get_field :obexit_prolog obxi)) )
+    (assert_msg "check olab" (is_a olab class_clonedsymbol))
+    (add2sbuf_strconst implbuf "/*exit*/{")
+    (add2sbuf_indentnl implbuf depth)
+    (if (is_a oprolog class_objinstr)
+	(progn
+	(output_c_code oprolog declbuf implbuf (+i depth 1))
+	(add2sbuf_strconst implbuf ";")
+	(add2sbuf_indentnl implbuf (+i depth 1))
+	))
+    (add2sbuf_strconst implbuf " goto labexit_")
+    (add2sbuf_clonsym implbuf olab)	
+    (add2sbuf_strconst implbuf ";}")
+    (add2sbuf_indentnl implbuf depth)    
+))
+(install_method class_objexit output_c_code outpucod_objexit)
+
+;;; output code for objcompute
+(defun outpucod_objcompute (obcomp declbuf implbuf :long depth)
+  (assert_msg "check obcomp" (is_a obcomp class_objcompute))
+  (let ( (cdest (unsafe_get_field :obcpt_dest obcomp)) ; destination list
+	 (cloc (unsafe_get_field :obi_loc obcomp))
+	 (cexp (unsafe_get_field :obcpt_expr obcomp)) 
+	 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
+	 )
+    (output_location cloc implbuf depth)
+    (list_iterate 
+     cdest
+     (lambda (destcur) 
+       (output_c_code destcur declbuf implbuf (get_int boxdepthp1))
+       (add2sbuf_strconst implbuf " = ")
+       cdest))
+    (if (is_list cexp)
+	(list_iterate 
+	 cexp 
+	 (lambda (expcur) 
+	   (output_c_code expcur declbuf implbuf (get_int boxdepthp1))
+	   cexp))
+      (output_c_code cexp declbuf implbuf (+i depth 1))
+      )))
+(install_method class_objcompute output_c_code outpucod_objcompute)
+
+
+;; output a conditional
+(defun outpucod_objcond (ocond declbuf implbuf :long depth)
+  (assert_msg "check ocond" (is_a ocond class_objcond))
+  (debug_msg "outpucod_objcond ocond" ocond (the_callcount))
+  (let ( (cloc (unsafe_get_field :obi_loc ocond))
+	 (ctest (unsafe_get_field :obcond_test ocond))
+	 (cthen (unsafe_get_field :obcond_then ocond))
+	 (celse (unsafe_get_field :obcond_else ocond)) 
+	 )
+    (output_location cloc implbuf depth)
+    (add2sbuf_strconst implbuf "/*cond*/ if (")
+    (output_c_code ctest declbuf implbuf (+i depth 1))
+    (add2sbuf_strconst implbuf ") /*then*/ {")
+    (add2sbuf_indentnl implbuf depth)
+    (output_c_code cthen declbuf implbuf (+i depth 1))
+    (add2sbuf_strconst implbuf ";")
+    (add2sbuf_indentnl implbuf depth)
+    (if celse 
+	(progn
+	  (add2sbuf_indentnl implbuf depth)
+	  (add2sbuf_strconst implbuf "} else {")
+	  (add2sbuf_indentnl implbuf (+i depth 1))
+	  (output_c_code celse declbuf implbuf (+i depth 1))
+	  (add2sbuf_strconst implbuf ";")
+	  (add2sbuf_indentnl implbuf (+i depth 1))
+	  (add2sbuf_strconst implbuf "}") ;
+	  )
+      (add2sbuf_strconst implbuf "} /*noelse*/")
+      )
+    (add2sbuf_indentnl implbuf depth)
+    ) 
+  (debug_msg "outpucod_objcond end ocond" ocond (the_callcount))
+  )
+(install_method class_objcond output_c_code outpucod_objcond)
+
+;; output an application
+(defun outpucod_objapply (oapp declbuf implbuf :long depth)
+  (assert_msg "check oapp" (is_a oapp class_objapply))
+  (debug_msg "outpucod_objapply oapp" oapp (the_callcount))
+  (let (
+	(aloc (unsafe_get_field :obi_loc oapp))
+	(adest (unsafe_get_field :obapp_dest oapp))
+	(oclos (unsafe_get_field :obapp_clos oapp))
+	(oargs (unsafe_get_field :obapp_args oapp))
+	(:long nbarg (multiple_length oargs))
+	(paramdesclist (make_list discr_list))
+	(boxdepthp1 (make_integerbox discr_integer (+i 1 depth)))
+	)
+    (output_location aloc implbuf depth)
+    (add2sbuf_strconst implbuf "/*apply*/{")
+    (add2sbuf_indentnl implbuf (+i 1 depth))
+    (if (>i nbarg 1)
+	(progn
+	  (add2sbuf_strconst implbuf "union basilysparam_un argtab[")
+	  (add2sbuf_longdec implbuf (-i nbarg 1))
+	  (add2sbuf_strconst implbuf "];")
+	  (add2sbuf_indentnl implbuf (+i 1 depth))
+	  (add2sbuf_strconst implbuf "memset(&argtab, 0, sizeof(argtab));")
+	  (add2sbuf_indentnl implbuf (+i 1 depth))
+	  ;; output the initialization of argtab and fill the paramdesclist
+	  (multiple_iterate 
+	   oargs
+	   (lambda (curarg :long curank)
+	     (debug_msg "outputcod_objapply curarg" curarg)
+	     (debug_msg "outputcod_objapply curarg discr" (discrim curarg))
+	     (cbreak_msg "outputcod_objapply curarg")
+	     (if (>i curank 0)
+		 (let ( (curctyp (get_ctype curarg (the_null))) )
+		   (debug_msg "outputcod_objapply curctyp" curctyp)
+		   (assert_msg "check curctyp" (is_a curctyp class_ctype))
+		   (output_location aloc implbuf (get_int boxdepthp1))
+		   (add2sbuf_strconst implbuf "argtab[")
+		   (add2sbuf_longdec implbuf  (-i curank 1))
+		   (add2sbuf_strconst implbuf "].")
+		   (list_append paramdesclist (unsafe_get_field :ctype_parstring curctyp))
+		   (if (== curctyp ctype_value)
+		       (progn
+			 (add2sbuf_strconst implbuf "bp_aptr = (basilys_ptr_t*) &")
+			 (output_c_code curarg declbuf implbuf (get_int boxdepthp1))
+			 )
+		     (progn
+		       (add2sbuf_string implbuf (unsafe_get_field :ctype_argfield curctyp))
+		       (add2sbuf_strconst implbuf " = ")
+		       (output_c_code curarg declbuf implbuf (get_int boxdepthp1))
+		       ))
+		   (add2sbuf_strconst implbuf ";")
+		   ))
+	     oargs
+	     ))
+	  (add2sbuf_indentnl implbuf (get_int boxdepthp1))
+	  ))
+;;; output the destination(s)
+    (list_iterate 
+     adest
+     (lambda (curdest) 
+       (output_c_code curdest declbuf implbuf (get_int boxdepthp1))
+       (add2sbuf_strconst implbuf " = ")
+       adest
+       )
+     )
+    ;; output the apply and the closure
+    (add2sbuf_strconst implbuf " basilysgc_apply ((void*)(")
+    (output_c_code oclos declbuf implbuf (+i 1 depth))
+    (add2sbuf_strconst implbuf "), (")
+    ;; output the first argument
+    (let ( (firstarg (multiple_nth oargs 0)) )
+      (output_c_code firstarg declbuf implbuf (+i 1 depth))
+      )
+    (add2sbuf_strconst implbuf "), (")
+    ;; output the argdescr string
+    (list_iterate 
+     paramdesclist
+     (lambda (pard)
+       (add2sbuf_string implbuf pard)
+       (add2sbuf_strconst implbuf " ")
+       paramdesclist))
+    (add2sbuf_strconst implbuf "\"\"), ")
+    ;; output the argtab (or null if none)
+    (if (>i nbarg 1)
+	(add2sbuf_strconst implbuf "argtab,")
+      (add2sbuf_strconst implbuf "(union basilysparam_un*)0,"))
+    ;; no extra results
+    (add2sbuf_strconst implbuf " \"\", (union basilysparam_un*)0")
+    (add2sbuf_strconst implbuf ");")
+    (add2sbuf_indentnl implbuf (+i 1 depth))
+    (add2sbuf_strconst implbuf "}")
+    (add2sbuf_indentnl implbuf depth)
+    )
+  )
+(install_method class_objapply output_c_code outpucod_objapply)
+
+;; output a clear
+(defun outpucod_objclear (oclear declbuf implbuf :long depth)
+  (assert_msg "check oclear" (is_a oclear class_objclear))
+  (debug_msg "outpucod_objclear oclear" oclear (the_callcount))
+  (let ( (cloc (unsafe_get_field :obi_loc oclear))
+	 (cvl (unsafe_get_field :oclr_vloc oclear))
+	 )
+    (output_location cloc implbuf depth)
+    (add2sbuf_strconst implbuf "/*clear*/ ")
+    (output_c_code cvl declbuf implbuf (+i depth 1))
+    (add2sbuf_strconst implbuf " = 0 ")
+    )
+  )
+(install_method class_objclear output_c_code outpucod_objclear)
+
+;; output a raw object allocation
+(defun outpucod_objrawallocobj (oralob declbuf implbuf :long depth)
+  (assert_msg "check oralob" (is_a oralob class_objrawallocobj))
+  (debug_msg "outpucod_objrawallocobj oralob" oralob)
+  (let ( (iloc (unsafe_get_field :obi_loc oralob))
+	 (iclass (unsafe_get_field :obrallobj_class oralob))
+	 (ilen (unsafe_get_field :obrallobj_len oralob))
+	 (destlist (unsafe_get_field :obrallobj_dest oralob)) 
+	 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
+	 )
+    (output_location iloc implbuf depth)
+    (add2sbuf_strconst implbuf "/*rawallocobj*/")
+    (list_iterate 
+     destlist
+     (lambda (dst) 
+       (output_c_code dst declbuf implbuf (get_int boxdepthp1))
+       (add2sbuf_strconst implbuf " = ")
+       destlist))
+    (add2sbuf_strconst implbuf "basilysgc_new_raw_object((")
+    (output_c_code iclass declbuf implbuf (get_int boxdepthp1))
+    (add2sbuf_strconst implbuf "), (")
+    (output_c_code ilen  declbuf implbuf (get_int boxdepthp1))
+    (add2sbuf_strconst implbuf "));")
+    (add2sbuf_indentnl implbuf depth)
+))
+(install_method class_objrawallocobj output_c_code outpucod_objrawallocobj)
+
+
+;; output a closure allocation
+(defun outpucod_objnewclosure (obnclo declbuf implbuf :long depth)
+  (assert_msg "check oralob" (is_a obnclo class_objnewclosure))
+  (debug_msg "outpucod_objnewclosure obnclo" obnclo) 
+  (let ( (iloc (unsafe_get_field :obi_loc obnclo))
+	 (odiscr (unsafe_get_field :obnclo_discr obnclo))
+	 (orout (unsafe_get_field :obnclo_rout obnclo))
+	 (olen (unsafe_get_field :obnclo_len obnclo))
+	 (destlist (unsafe_get_field :obnclo_dest obnclo))
+	 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
+	 )
+    (output_location iloc implbuf depth)
+    (add2sbuf_strconst implbuf "/*newclosure*/")
+    (list_iterate 
+     destlist
+     (lambda (dst) 
+       (output_c_code dst declbuf implbuf (get_int boxdepthp1))
+       (add2sbuf_strconst implbuf " = ")
+       destlist))
+    (add2sbuf_strconst implbuf "basilysgc_new_closure((basilysobject_ptr_t)(")
+    (output_c_code odiscr declbuf implbuf (get_int boxdepthp1))
+    (add2sbuf_strconst implbuf "), (basilysroutine_ptr_t)(")
+    (output_c_code orout declbuf implbuf (get_int boxdepthp1))
+    (add2sbuf_strconst implbuf "), (")
+    (output_c_code olen declbuf implbuf (get_int boxdepthp1))
+    (add2sbuf_strconst implbuf "));")
+    (add2sbuf_indentnl implbuf depth)
+))
+(install_method class_objnewclosure  output_c_code outpucod_objnewclosure)
+
+;; output a touch
+(defun outpucod_objtouch (otouch declbuf implbuf :long depth)
+  (assert_msg "check oclear" (is_a otouch class_objtouch))
+  (let ( (iloc (unsafe_get_field :obi_loc otouch)) 
+	 (touched (unsafe_get_field :otouch_val otouch)) 
+	 (comm (unsafe_get_field :otouch_comment otouch))
+	 )
+    (output_location iloc implbuf depth)
+    (if comm 
+	(progn 
+	       (add2sbuf_strconst implbuf "/*touch:")
+	       (add2sbuf_cident implbuf comm)
+	       (add2sbuf_strconst implbuf "*/")))
+    (add2sbuf_strconst implbuf " basilysgc_touch(")
+    (output_c_code touched declbuf implbuf depth)
+    (add2sbuf_strconst implbuf ");")
+    (add2sbuf_indentnl implbuf depth)
+    )
+)
+(install_method class_objtouch output_c_code outpucod_objtouch)
+
+
+
+;;; output a put tuple (mostly used in initial data content filling)
+(defun outpucod_objputuple (optup declbuf implbuf :long depth)
+  (assert_msg "check optyp" (is_a optup class_objputuple))
+  (debug_msg "outpucod_objputuple optup" optup (the_callcount))
+  (let ( (iloc (unsafe_get_field :obi_loc optup))
+	 (otup (unsafe_get_field :oputu_tupled optup))
+	 (ooff (unsafe_get_field :oputu_offset optup))
+	 (oval (unsafe_get_field :oputu_value optup)) )
+    (output_location iloc implbuf depth)
+    (add2sbuf_strconst implbuf "/*putuple*/ ((basilysmultiple_ptr_t)(")
+    (output_c_code otup declbuf implbuf depth)
+    (add2sbuf_strconst implbuf "))->tabval[")
+    (output_c_code ooff declbuf implbuf depth)
+    (add2sbuf_strconst implbuf "] = ")
+    (output_c_code oval declbuf implbuf depth)
+    (add2sbuf_strconst implbuf ";")
+    (add2sbuf_indentnl implbuf depth)
+    )
+  )
+(install_method class_objputuple output_c_code outpucod_objputuple)
+
+
+;;; output a put slot (mostly used in initial data content filling)
+(defun outpucod_objputslot (opslo declbuf implbuf :long depth)
+  (assert_msg "check opslo" (is_a opslo class_objputslot))
+  (debug_msg "outpucod_objputslot opslo" opslo (the_callcount))
+  (let ( (iloc (unsafe_get_field :obi_loc opslo))
+	 (odata (unsafe_get_field :oslot_odata opslo))
+	 (ooff (unsafe_get_field :oslot_offset opslo))
+	 (oval (unsafe_get_field :oslot_value opslo))
+	 )
+    (output_location iloc implbuf depth)
+    (add2sbuf_strconst implbuf "/*putslot*/ ((basilysobject_ptr_t)(")
+    (output_c_code odata declbuf implbuf depth)
+    (add2sbuf_strconst implbuf "))->obj_vartab[")
+    (output_c_code ooff declbuf implbuf depth)
+    (add2sbuf_strconst implbuf "] = ")
+    (output_c_code oval declbuf implbuf depth)
+    (add2sbuf_strconst implbuf ";")
+    (add2sbuf_indentnl implbuf depth)
+    ))
+(install_method class_objputslot output_c_code outpucod_objputslot)
+  
+
+;;; output the putting of the routine in a closure
+(defun outpucod_objputclosurout (opclor  declbuf implbuf :long depth)
+  (assert_msg "check opclor" (is_a opclor class_objputclosurout))
+  (debug_msg "outpucod_objputclosurout opclor" opclor)
+  (let ( (oloc (unsafe_get_field :obi_loc opclor))
+	 (oclos (unsafe_get_field :opclor_clos opclor))
+	 (orout (unsafe_get_field :opclor_rout opclor)) )
+    (output_location oloc implbuf depth)
+    (add2sbuf_strconst implbuf "/*putclosrout*/ ((basilysclosure_ptr_t)")
+    (output_c_code oclos declbuf implbuf depth)
+    (add2sbuf_strconst implbuf ")->rout = ")
+    (output_c_code orout declbuf implbuf depth)
+    (add2sbuf_strconst implbuf ";")
+    (add2sbuf_indentnl implbuf depth)
+    )
+)
+(install_method class_objputclosurout output_c_code outpucod_objputclosurout)
+
+;;; output the putting of a closed value
+(defun outpucod_objputclosedv (opclov declbuf implbuf :long depth)
+  (assert_msg "check opclor" (is_a opclov class_objputclosedv))
+  (debug_msg "outpucod_objputclosedv" opclov)
+  (let ( (oloc (unsafe_get_field :obi_loc opclov))
+	 (oclos (unsafe_get_field :opclov_clos opclov))
+	 (ooff (unsafe_get_field :opclov_off opclov))
+	 (ocval (unsafe_get_field :opclov_cval opclov)) )
+    (output_location oloc implbuf depth)
+    (add2sbuf_strconst implbuf "/*putclosval*/ ((basilysclosure_ptr_t)")
+    (output_c_code oclos declbuf implbuf depth)
+    (add2sbuf_strconst implbuf ")->tabval[")
+    (output_c_code ooff declbuf implbuf depth)
+    (add2sbuf_strconst implbuf "] = ")
+    (output_c_code ocval declbuf implbuf depth)
+    (add2sbuf_strconst implbuf ";")
+    (add2sbuf_indentnl implbuf depth)
+    ))
+(install_method class_objputclosedv output_c_code outpucod_objputclosedv)
+
+
+;; output the putting of a constant value inside a routine
+(defun outpucod_objputroutconst (oprconst declbuf implbuf :long depth)
+  (assert_msg "check oprconst" (is_a oprconst class_objputroutconst))
+  (let ( (oloc (unsafe_get_field :obi_loc oprconst))
+	 (orout (unsafe_get_field :oprconst_rout oprconst))
+	 (ooff (unsafe_get_field :oprconst_off oprconst))
+	 (ocval (unsafe_get_field :oprconst_cval oprconst)) )
+    (output_location oloc implbuf depth)
+    (add2sbuf_strconst implbuf "/*putroutconst*/ ((basilysroutine_ptr_t)")
+    (output_c_code orout declbuf implbuf depth)
+    (add2sbuf_strconst implbuf ")->tabval[")
+    (output_c_code ooff declbuf implbuf depth)
+    (add2sbuf_strconst implbuf "] = ")
+    (output_c_code ocval declbuf implbuf depth)
+    (add2sbuf_strconst implbuf ";")
+    (add2sbuf_indentnl implbuf depth)
+    )
+  )
+(install_method class_objputroutconst output_c_code outpucod_objputroutconst)
+
+;;; output an expression
+(defun outpucod_objexpv (oexp declbuf implbuf :long depth)
+  (assert_msg "check oexp" (is_a oexp class_objexpv))
+  (let ( (cont (unsafe_get_field :obx_cont oexp)) 
+	 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
+	 )
+    (assert_msg "check cont" (is_multiple cont))
+    (multiple_iterate
+     cont
+     (lambda (comp :long ix)
+       (output_c_code comp declbuf implbuf (get_int boxdepthp1))
+       cont)))
+)
+(install_method class_objexpv output_c_code outpucod_objexpv)
+
+;;; output a verbatim string
+(defun outpucod_verbatimstring (vstr declbuf implbuf :long depth)
+  (assert_msg "check vstr" (== (discrim vstr) discr_verbatimstring))
+  (add2sbuf_string implbuf vstr)
+)
+(install_method discr_verbatimstring output_c_code outpucod_verbatimstring)
+
+;; output a string (cstring constant)
+(defun outpucod_string (vstr declbuf implbuf :long depth)
+  (assert_msg "check vstr" (== (discrim vstr) discr_string)) 
+  (add2sbuf_strconst implbuf " \"")
+  (add2sbuf_cencstring implbuf vstr)
+  (add2sbuf_strconst implbuf "\"")
+)
+(install_method discr_string output_c_code outpucod_string)
+
+;;; output an integer
+(defun outpucod_integer (vint declbuf implbuf :long depth)
+  (assert_msg "check vint" (is_integerbox vint))
+  (add2sbuf_longdec implbuf (get_int vint))
+)
+(install_method discr_integer output_c_code outpucod_integer)
+
+;;; output a finalreturn
+(defun outpucod_finalreturn (fret declbuf implbuf :long depth)
+  (assert_msg "check fret" (is_a fret class_objfinalreturn))
+  (output_location (unsafe_get_field :obi_loc fret))
+  (add2sbuf_strconst implbuf "/*finalret*/ goto labend_rout ")
+)
+(install_method class_objfinalreturn output_c_code outpucod_finalreturn)
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; compile a single procedure
+(defun compile2obj_procedure (pro compicache :long num)
+  (debug_msg "compilproc pro" pro (the_callcount))
+  (debug_msg "compilproc compicache" compicache (the_callcount))
+  (assert_msg "check pro" (is_a pro class_nrep_routproc))
+  (assert_msg "check compicache" (is_mapobject compicache))
+  (let ( (namsbuf (make_strbuf discr_strbuf)) )
+    (add2sbuf_strconst namsbuf "rout_")
+    (add2sbuf_longdec namsbuf num)
+    (if (is_a pro class_nrep_routproc)
+	(let ( (pronam (unsafe_get_field :nrpro_name pro)) 
+	       )
+	  (if (is_a pronam class_named)
+	      (progn
+		(add2sbuf_strconst namsbuf "_")
+		(add2sbuf_cident namsbuf (unsafe_get_field :named_name pronam)))
+	    )))
+    (let ( 
+	  (nbody (unsafe_get_field :nproc_body pro))
+	  (nargb (unsafe_get_field :nrpro_argb pro))
+	  (obodylist (make_list discr_list))
+	  (obrout (make_instance class_procroutineobj
+				 :named_name (strbuf2string discr_string namsbuf)
+				 :obrout_proc pro
+				 :obrout_body obodylist
+				 :obrout_nbval (make_integerbox discr_integer 0)
+				 :obrout_nblong (make_integerbox discr_integer 0)
+				 )) 
+	  (locmap (make_mapobject discr_mapobjects (+i 20 (*i 3 (multiple_length nargb)))))
+	  (gcx (make_instance class_genercontext
+			      :gncx_objrout obrout
+			      :gncx_locmap locmap
+			      :gncx_freeptrlist (make_list discr_list)
+			      :gncx_freelonglist (make_list discr_list)
+			      :gncx_freeothermaps (make_mapobject discr_mapobjects 20)
+			      :gncx_compicache compicache
+			      ))
+	  (retloc 
+	   (let ( (retl (get_free_objlocptr gcx '_retval_)) )
+	     (unsafe_put_fields gcx :gncx_retloc retl)
+	     retl))
+	  (gtatup 
+	   (multiple_map 
+	    nargb
+	    (lambda (bnd :long ix)
+	      (assert_msg "check bnd" (is_a bnd class_formal_binding))
+					;	      (debug_msg "compilproc bnd" bnd (the_callcount))
+	      (let ( (bctyp (unsafe_get_field :fbind_type bnd)) 
+		     (bnam (unsafe_get_field :binder bnd))
+		     (oloc 
+		      (cond ( (== bctyp ctype_value)
+			      (get_free_objlocptr gcx bnam) )
+			    ( (== bctyp ctype_long)
+			      (get_free_objloclong gcx bnam) )
+			    (:else
+			     (get_free_objloctyped gcx bnam bctyp)))
+		      ) 
+		     (ogarg
+		      (make_instance class_objgetarg
+				     :obi_loc (unsafe_get_field :nrep_loc pro)
+				     :obarg_obloc oloc
+				     :obarg_bind bnd))
+		     )
+		(mapobject_put locmap bnd oloc)
+		ogarg
+		))
+	    ))
+	  )
+      ;; associate the procedure with its objroutine in the compiler cache
+      (mapobject_put compicache pro obrout)
+      (unsafe_put_fields obrout :oprout_getargs gtatup)
+      (debug_msg "compile2obj_procedure obrout" obrout (the_callcount))
+      (debug_msg "compile2obj_procedure nbody" nbody (the_callcount))
+      (assert_msg "check nbody" (is_a nbody class_nrep))
+      (if (is_a pro class_nrep_routproc)
+	  (let ( (pthuls (unsafe_get_field :nrpro_thunklist pro)) )
+	    (debug_msg "compile2obj_procedure pthuls" pthuls (the_callcount))
+	    (list_iterate 
+	     pthuls
+	     (lambda (pthu) 
+	       (debug_msg "compile2obj_procedure pthu" pthu)
+	       (assert_msg "compile2obj_procedure check pthu" (is_closure pthu))
+	       (pthu gcx)
+	       pthu
+	       )
+	    )))
+      (let ( (obody (compile_obj nbody gcx)) 
+	     )
+	(debug_msg "compile2obj_procedure obody" obody (the_callcount))
+	(list_append obodylist obody)
+	)
+      (debug_msg "compile2obj_procedure return obrout" obrout (the_callcount))
+      obrout
+      )))
+
+;;;; compile the initial procedure into an object
+(defun compile2obj_initproc (ipro idata compicache)
+  (assert_msg "check ipro" (is_a ipro class_nrep_initproc))
+  (assert_msg "check idata" (is_list idata))
+  (assert_msg "check compicache" (is_mapobject compicache))
+  (debug_msg "compile2obj_initproc ipro" ipro (the_callcount))
+  (debug_msg "compile2obj_initproc compicache" compicache (the_callcount))
+  (let ( (locmap (make_mapobject discr_mapobjects 50))
+	 (oinibody (make_list discr_list))
+	 (oinitrout
+	  (make_instance class_initialroutineobj
+			 :named_name (make_stringconst discr_string "start_module_basilys")
+			 :obrout_proc ipro
+			 :obrout_body oinibody
+			 :obrout_nbval (make_integerbox discr_integer 0)
+			 :obrout_nblong (make_integerbox discr_integer 0)
+			 :oirout_fill (make_list discr_list)
+			 ))
+	 (gcx (make_instance class_genercontext
+			     :gncx_objrout oinitrout
+			     :gncx_locmap locmap
+			     :gncx_freeptrlist (make_list discr_list)
+			     :gncx_freelonglist (make_list discr_list)
+			     :gncx_freeothermaps (make_mapobject discr_mapobjects 20)
+			     :gncx_compicache compicache
+			     ))
+	 (retloc 
+	  (let ( (retl (get_free_objlocptr gcx '_retinit_)) )
+	    (unsafe_put_fields gcx :gncx_retloc retl)
+	    retl))
+	 (odatatup 
+	  (list_to_multiple
+	   idata discr_multiple
+	   (lambda (curdat)
+	     (debug_msg "compile2obj_initproc curdat" curdat (the_callcount))
+	     (assert_msg "check curdat" (is_a curdat class_nrep_data))
+	     (let ( (curobd (compile_obj curdat gcx)) )
+	       (debug_msg "compile2obj_initproc curobd" curobd (the_callcount))
+	       curobd))))
+	 (toplis (unsafe_get_field :ninit_topl ipro)) 
+	 )
+    (unsafe_put_fields oinitrout
+		       :oirout_data odatatup)
+    (assert_msg "check toplis" (is_list_or_null toplis))
+    (list_iterate 
+     toplis
+     (lambda (curtop)
+       (let ( (otop (compile_obj curtop gcx)) )
+	 (debug_msg "compile2obj_initproc otop" otop (the_callcount))
+	 (list_append oinibody otop)
+	 toplis
+	 )))
+    (debug_msg "compile2obj_initproc final gcx" gcx (the_callcount))
+    (debug_msg "compile2obj_initproc final oinitrout" oinitrout (the_callcount))
+;    (assert_msg "compile2obj_initproc @@@ A COMPLETER" ())
+    oinitrout
+    ))
+
+;; compile a list of sexpressions as a module starting from a given environment
+(defun compile_list_sexpr (lsexp inienv modnamstr)
+  (debug_msg "\n\n*compile_list_sexpr lsexp" lsexp (the_callcount)) ;list of sexpr
+  (debug_msg "compile_list_sexpr inienv" inienv (the_callcount)) ;initial environment
+  (debug_msg "compile_list_sexpr modnamstr" modnamstr (the_callcount)) ;module name
+  (assert_msg "check lsexp" (is_list lsexp))
+  (assert_msg "check modnamstr" (is_string modnamstr))
+  (assert_msg "check inienv" (is_a inienv class_environment))
+  (let ( (ncx (create_normcontext)) )
+    (debug_msg "compile_list_sexpr initial ncx" ncx (the_callcount))
+    (assert_msg "check ncx" (is_a ncx class_normcontext))
+    (let ( (xlist (macroexpand_toplevel_list lsexp inienv)) 
+	   (iniproc (unsafe_get_field :nctx_initproc ncx))
+	   )
+      (debug_msg "after macroexpansion compile_list_sexpr seq" xlist (the_callcount))
+      (debug_msg "after macroexpansion compile_list_sexpr inienv" inienv (the_callcount))
+      (assert_msg "check iniproc" (is_a iniproc class_nrep_initproc))
+      (list_iterate 
+       xlist
+       (lambda (sexp :long ix)
+	 (debug_msg "compile_list_sexpr sexp" sexp (the_callcount))
+	 (let (
+	       (psloc (if (is_a sexp class_located) (unsafe_get_field :loca_location sexp)))
+	       )
+	   (multicall 
+	    (nexp nbind)
+	    (normal_exp sexp inienv ncx psloc)	    
+	    (debug_msg "compile_list_sexpr nexp" nexp (the_callcount))    
+	    (debug_msg "compile_list_sexpr nbind" nbind (the_callcount))
+	    (if (and (is_a nexp class_nrep)
+		     (not (is_a nexp class_nrep_anyproc)))
+		(let ( (wnexp (wrap_normal_let1 nexp nbind psloc)) )
+		  (debug_msg "compile_list_sexpr wnexp" wnexp (the_callcount))
+		  (list_append (unsafe_get_field :ninit_topl iniproc) 
+			       wnexp)
+		  ))
+	    sexp
+	    ))))
+      (let ( (prolist (unsafe_get_field :nctx_proclist ncx)) 
+	     (objlist (make_list discr_list))
+	     (compicache (make_mapobject discr_mapobjects (+i 10 (*i 20 (list_length xlist)))))
+	     (countbox (make_integerbox discr_integer 0))
+	     )
+	(assert_msg "check prolist" (is_list prolist))
+	(list_iterate
+	 prolist
+	 (lambda (pro)
+	   (assert_msg "check pro" (is_a pro class_nrep_anyproc))
+	   (debug_msg "compile_list_sexpr pro" pro (the_callcount))
+	   (put_int countbox (+i (get_int countbox) 1))
+	   (let ( (objpro (compile2obj_procedure pro compicache (get_int countbox))) )
+	     (debug_msg "compile_list_sexpr objpro" objpro (the_callcount))
+	     (debug_msg "compile_list_sexpr done pro" pro (the_callcount))
+	     (list_append objlist objpro)
+	     (debug_msg "compile_list_sexpr compicache" compicache (the_callcount))
+	     objpro
+	     ))
+	 )
+	(debug_msg "compilistsexpr ncx avant inipro" ncx (the_callcount))
+	(let ( (inipro (unsafe_get_field :nctx_initproc ncx)) 
+	       (inidata (unsafe_get_field :nctx_datalist ncx))
+	       )
+	  (assert_msg "check inipro" (is_a inipro class_nrep_initproc))
+	  (debug_msg "compilistsexpr avant compilinitproc compicache" compicache (the_callcount))
+	  (let ( (iniobj (compile2obj_initproc inipro inidata compicache)) )
+	    (debug_msg "compile_list_sexpr iniobj" iniobj (the_callcount))
+	    (let ( (declbuf (make_strbuf discr_strbuf))
+		   (implbuf (make_strbuf discr_strbuf)) 
+		   )
+	      (list_iterate
+	       objlist
+	       (lambda (obel)
+		 (debug_msg "compile_list_sexpr obel" obel (the_callcount))
+		 (output_c_code obel declbuf implbuf 0)
+		 objlist))
+	      (debug_msg "compile_list_sexpr final modnamstr" modnamstr (the_callcount)) 
+	      (debug_msg "compile_list_sexpr outputting iniobj" iniobj (the_callcount))
+	      (output_c_code iniobj declbuf implbuf 0)
+	      (output_cfile_decl_impl modnamstr declbuf implbuf)
+	      )))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; function to get a free local value pointer for some name
+(defun get_free_objlocptr (gcx nam)
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (let ( (orout (unsafe_get_field :gncx_objrout gcx))
+	 (freeli (unsafe_get_field :gncx_freeptrlist gcx)) 
+	 (pfree (list_popfirst freeli))
+	 )
+    (if (not (is_a orout class_routineobj))
+	(progn
+	  (debug_msg "get_free_objlocptr bad orout" orout (the_callcount))
+	  (shortbacktrace_dbg "get_free_objlocptr bad orout" 15)))
+    (assert_msg "check orout" (is_a orout class_routineobj))
+    (if (is_a pfree  class_objlocv)
+	(let ( (nambuf (make_strbuf discr_strbuf)) )
+	  (assert_msg "check pfreetyo" (== ctype_value (unsafe_get_field :obv_type pfree)))
+	  (if (is_a nam class_named)
+	      (add2sbuf_cident nambuf (unsafe_get_field :named_name nam)))
+	  (add2sbuf_strconst nambuf "__V")
+	  (add2sbuf_longdec nambuf (get_int (unsafe_get_field :obl_off pfree)))
+	  (unsafe_put_fields pfree :obl_cname (strbuf2string discr_string nambuf))
+	  pfree)
+      (let ( (nbvalbox (unsafe_get_field :obrout_nbval orout)) 
+	     (:long nbval (get_int nbvalbox))  
+	     (nambuf (make_strbuf discr_strbuf))
+	     )
+	(if (is_a nam class_named)
+	    (add2sbuf_cident nambuf (unsafe_get_field :named_name nam)))
+	(add2sbuf_strconst nambuf "__V")
+	(add2sbuf_longdec nambuf (+i nbval 1))
+	(put_int nbvalbox (+i nbval 1))
+	(let ( (nloc (make_instance class_objlocv
+				    :obv_type ctype_value
+				    :obl_off (make_integerbox discr_integer nbval)
+				    :obl_proc orout
+				    :obl_cname (strbuf2string discr_string nambuf))) )
+	  nloc
+	  )))))
+
+;;; function to get a free local long for some name
+(defun get_free_objloclong (gcx nam)
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (let ( (orout (unsafe_get_field :gncx_objrout gcx))
+	 (freeli (unsafe_get_field :gncx_freelonglist gcx)) 
+	 (pfree (list_popfirst freeli))
+	 )
+    (assert_msg "check orout" (is_a orout class_routineobj))
+    (if (is_a pfree  class_objlocv)
+	(let ( (nambuf (make_strbuf discr_strbuf)) )
+	  (assert_msg "check pfreetyo" (== ctype_long (unsafe_get_field :obv_type pfree)))
+	  (if (is_a nam class_named)
+	      (add2sbuf_cident nambuf (unsafe_get_field :named_name nam)))
+	  (add2sbuf_strconst nambuf "__L")
+	  (add2sbuf_longdec nambuf (get_int (unsafe_get_field :obl_off pfree)))
+	  (unsafe_put_fields pfree :obl_cname (strbuf2string discr_string nambuf))
+	  pfree)
+      (let ( (nblongbox (unsafe_get_field :obrout_nblong orout)) 
+	     (:long nblong (get_int nblongbox))  
+	     (nambuf (make_strbuf discr_strbuf))
+	     )
+	(if (is_a nam class_named)
+	    (add2sbuf_cident nambuf (unsafe_get_field :named_name nam)))
+	(add2sbuf_strconst nambuf "__L")
+	(add2sbuf_longdec nambuf (+i nblong 1))
+	(put_int nblongbox (+i nblong 1))
+	(let ( (nloc (make_instance class_objlocv
+				    :obv_type ctype_long
+				    :obl_off (make_integerbox discr_integer nblong)
+				    :obl_cname (strbuf2string discr_string nambuf))) )
+	  nloc
+	  )))))
+
+;;; function to get a free local otherstuff for some name and ctype
+;;; @@ NOT IMPLEMENTED YET for arbitrary ctypes
+(defun get_free_objloctyped (gcx nam ctyp)
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  ;; (assert_msg "check ctyp" (is_a ctyp class_ctype))
+  (cond ( (== ctyp ctype_long)
+	  (get_free_objloclong gcx nam))
+	( (== ctyp ctype_value)
+	  (get_free_objlocptr gcx nam))
+	;; return null for the void ctype
+	( (== ctyp ctype_void)
+	  ())
+	(:else 
+	 (debug_msg "getfreeobjloctyped nam" nam (the_callcount))
+	 (debug_msg "getfreeobjloctyped ctyp" ctyp (the_callcount))
+	 (assert_msg "@@@ unimplemented get_free_objloctyped for other ctyp" ())
+)))
+  
+
+
+;; function to dispose, i.e. mark as free, a binding 
+(defun dispose_bnd_obj (bnd gcx)
+  (assert_msg "check bnd" (is_a bnd class_any_binding))
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (let ( (locmap (unsafe_get_field :gncx_locmap gcx))
+	 (oldloc (mapobject_get locmap bnd)) )
+    (if (null oldloc)
+	(progn
+	  ;; special hack to dispose a void let binding - return immediately in that case
+	  (and (is_a bnd class_let_binding)
+	       (== (unsafe_get_field :letbind_type bnd) ctype_void)
+	       (return))
+	  (debug_msg "dispose_bnd_obj nulloldloc bnd" bnd (the_callcount))
+	  ))
+    (assert_msg "check oldloc" (is_a oldloc class_objlocv))
+    (mapobject_remove locmap bnd)
+    (let ( (oldcty (unsafe_get_field :obv_type oldloc)) )
+      (cond ( (== oldcty ctype_value)
+	      (let  ( (freepl (unsafe_get_field :gncx_freeptrlist gcx)) )
+		(list_append freepl oldloc)))
+	    ( (== oldcty ctype_long)
+	      (let  ( (freenl (unsafe_get_field :gncx_freelonglist gcx)) )
+		(list_append freenl oldloc)))
+	    (:else
+	     ;; we have a map from ctypes to free list, add it there!
+	     (assert_msg "@@@ unimplemented dispose_bnd_obj non-value non-long" ())))
+)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun compilobj_nrep_chunk (nchk gcx)
+  (assert_msg "check nchk" (is_a nchk class_nrep_chunk))
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (debug_msg "compilobj nrepchunk nchk" nchk (the_callcount))
+;  (debug_msg "compilobj nrepchunk gcx" gcx (the_callcount))
+;  (debug_msg "compilobj nrepchunk env" env (the_callcount))
+  (let ( (loc (unsafe_get_field :nrep_loc nchk))
+	 (nexp (unsafe_get_field :nchunk_expansion nchk))
+	 (nprim (unsafe_get_field :nchunk_primitive nchk))
+	 )
+    (assert_msg "check nprim" (is_a nprim class_primitive))
+    (assert_msg "check nexp" (is_multiple nexp))
+    (let (  (otup (multiple_map
+		   nexp
+		   (lambda (comp :long ix)
+		     (debug_msg "compobj nrepchunk comp" comp (the_callcount))
+		     (if (== (discrim comp) discr_verbatimstring)
+			 comp
+		       (compile_obj comp gcx)))
+		   ))
+	    (oexp (make_instance class_objexpv
+				 :obv_type (unsafe_get_field :prim_type nprim)
+				 :obx_cont otup
+				 ))      
+	    )
+      (debug_msg "compiobj nrepchunk oexp" oexp (the_callcount))
+      oexp)
+    ))
+(install_method class_nrep_chunk compile_obj compilobj_nrep_chunk)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun compilobj_nrep_locsymocc (lsyo gcx)
+  (assert_msg "check nchk" (is_a lsyo class_nrep_locsymocc))
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (let ( (loc (unsafe_get_field :nrep_loc lsyo))
+	 (locmap (unsafe_get_field :gncx_locmap gcx))
+	 (sym (unsafe_get_field :nocc_symb lsyo))
+	 (oty (unsafe_get_field :nocc_ctyp lsyo))
+	 (sbnd (unsafe_get_field :nocc_bind lsyo))
+	 (ovar (mapobject_get locmap sbnd))
+	 )
+;    (debug_msg "compilobj locsymocc gcx" gcx (the_callcount))
+    (debug_msg "compilobj locsymocc lsyo" lsyo (the_callcount))
+;    (debug_msg "compilobj locsymocc sbnd" sbnd (the_callcount))
+    (debug_msg "compilobj locsymocc oty" oty (the_callcount))
+    (debug_msg "compilobj locsymocc ovar" ovar (the_callcount))
+    (if (null sbnd)
+	(progn
+	  (debug_msg "compilobj locsymocc null sbnd for sym" sym (the_callcount))
+	  (shortbacktrace_dbg "compilobj locsymocc  null sbnd" 16)
+	  ))
+    (if (null ovar) 
+	(assert_msg "compilocsy null ovar with ctype_void" (== oty ctype_void))
+      (assert_msg "compilocsy check ovar"  (is_a ovar class_objlocv)))
+    ovar
+))
+(install_method class_nrep_locsymocc compile_obj compilobj_nrep_locsymocc)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun compilobj_nrep_closedocc (nclo gcx)
+  (assert_msg "check nclo" (is_a nclo class_nrep_closedocc))
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (debug_msg "compilobj closedocc nclo" nclo (the_callcount))
+  (debug_msg "compilobj closedocc gcx" gcx (the_callcount))
+  (let ( 
+	(orout (unsafe_get_field :gncx_objrout gcx))
+	(osym (unsafe_get_field :nocc_symb nclo))
+	(obind (unsafe_get_field :nocc_bind nclo))
+	(cprocs (unsafe_get_field :ncloc_procs nclo))
+	(lastcproc (pair_head (list_last cprocs)))
+	(nloc (unsafe_get_field :nrep_loc nclo))
+	)
+    (debug_msg "compilobj closedocc orout" orout (the_callcount))
+    (assert_msg "check lastcproc" (is_a lastcproc class_nrep_routproc))
+    (let ( (cloblis (unsafe_get_field :nrpro_closedb lastcproc)) 
+	   (:long clorank -1)
+	   )
+      (assert_msg "check cloblis" (is_list cloblis))
+      (let ( (curpair (list_first cloblis)) 
+	     (:long curank 0)
+	     )
+	(forever 
+	 looplis
+	 (if (not (is_pair curpair)) (exit looplis))
+	 (let ( (curbind (pair_head curpair)) )
+	   (if (== curbind obind)
+	       (progn
+		 (setq clorank curank)
+		 (exit looplis)))
+	   (setq curpair (pair_tail curpair))
+	   (setq curank (+i curank 1))
+	   ))
+	(assert_msg "check good closed rank" (>=i clorank 0))
+	(let ( (ocloccv 
+		(make_instance class_objcloccv
+			       :obv_type (unsafe_get_field :nocc_ctyp nclo)
+			       :obc_off (make_integerbox discr_integer
+							 clorank)
+			       :obc_proc lastcproc
+			       :obc_name (unsafe_get_field :named_name osym))) )
+	  (debug_msg "compilobj closedocc result ocloccv" ocloccv (the_callcount))
+	  ocloccv
+	  )))))
+  
+(install_method class_nrep_closedocc compile_obj compilobj_nrep_closedocc)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun compilobj_nrep_constocc (ncnst gcx)
+  (assert_msg "check ncnst" (is_a ncnst class_nrep_constocc))
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (debug_msg "compilobj constocc ncnst" ncnst (the_callcount))
+  (debug_msg "compilobj constocc gcx" gcx (the_callcount))
+  (let ( 
+	(orout (unsafe_get_field :gncx_objrout gcx))
+	(osym (unsafe_get_field :nocc_symb ncnst))
+	(cprocs (unsafe_get_field :ncloc_procs ncnst))
+	(lastcproc (pair_head (list_last cprocs)))
+	(nloc (unsafe_get_field :nrep_loc ncnst))
+	)
+    (debug_msg "compilobj constocc orout" orout (the_callcount))
+    (assert_msg "check lastcproc" (is_a lastcproc class_nrep_routproc))
+    (let ( (cnstlis (unsafe_get_field :nrpro_const lastcproc)) 
+	   (:long cnstrank -1)
+	   )
+      (assert_msg "check cnstlis" (is_list cnstlis))
+      (let ( (curpair (list_first cnstlis)) 
+	     (:long curank 0)
+	     )
+	(forever 
+	 looplis
+	 (if (not (is_pair curpair)) (exit looplis))
+	 (let ( (curelem (pair_head curpair)) )
+	   (if (== curelem ncnst)
+	       (progn
+		 (setq cnstrank curank)
+		 (exit looplis)))
+	   (setq curpair (pair_tail curpair))
+	   (setq curank (+i curank 1))
+	   ))
+	(assert_msg "check good const rank" (>=i cnstrank 0))
+	(let ( (oconstv 
+		(make_instance class_objconstv
+			       :obv_type (unsafe_get_field :nocc_ctyp ncnst)
+			       :obc_off (make_integerbox discr_integer
+							 cnstrank)
+			       :obc_proc lastcproc
+			       :obc_name (unsafe_get_field :named_name osym))) )
+	  (debug_msg "compilobj constocc result oconstv" oconstv (the_callcount))
+	  oconstv
+	  )))))
+  
+(install_method class_nrep_constocc compile_obj compilobj_nrep_constocc)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; compile a constant
+(defun compilobj_nrep_constant (nconst gcx)
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (assert_msg "check nconst" (is_a nconst class_nrep_constant))
+  (debug_msg "compilobj constant nconst" nconst (the_callcount))
+  (let ( (nloc (unsafe_get_field :nrep_loc nconst))
+	 (sval (unsafe_get_field :nconst_sval nconst))
+	 (data (unsafe_get_field :nconst_data nconst))
+	 (proc (unsafe_get_field :nconst_proc nconst))
+	 )
+    (if (is_a proc class_nrep_routproc)
+	(let ( (constlist (unsafe_get_field :nrpro_const proc)) 
+	       (curpair (list_first constlist))
+	       (:long coff -1)
+	       (:long curank 0)
+	       (nambuf (make_strbuf discr_strbuf))
+	       )
+	  (forever 
+	   constloop
+	   (if (is_pair curpair)
+	       (let ((curconst (pair_head curpair)))
+		 (if (== curconst data)
+		     (progn
+		       (setq coff curank)
+		       (exit constloop)))
+		 )
+	     (exit constloop))
+	   (setq curpair (pair_tail curpair))
+	   (setq curank (+i curank 1))
+	   )
+	  (assert_msg "check coff" (>=i coff 0))
+	  (add2sbuf_strconst nambuf "konst_")
+	  (add2sbuf_longdec nambuf coff)
+	  (if (is_a sval class_named)
+	      (progn
+		(add2sbuf_strconst nambuf "_")
+		(add2sbuf_cident nambuf (unsafe_get_field :named_name sval))
+		)
+	      )
+	  (let ( (constv 
+		  (make_instance class_objconstv
+				 :obv_type ctype_value
+				 :obc_off (make_integerbox discr_integer coff)
+				 :obc_proc proc
+				 :obc_name (strbuf2string discr_string nambuf)
+			  )) )
+	    (debug_msg "compilobj constant constv" constv (the_callcount))
+	    constv
+	    )
+	  )
+      (progn				
+	;; not inside a proc, just return the data
+	(debug_msg "compilobj constant just data" data (the_callcount))
+	(return data)
+	)
+      )
+    )
+  )
+(install_method class_nrep_constant compile_obj compilobj_nrep_constant)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; compile a forever
+(defun compilobj_nrep_forever (nfor gcx)
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (assert_msg "check nfor" (is_a nfor class_nrep_forever))
+  (debug_msg "compilobj_nrep_forever nfor" nfor (the_callcount))
+  (debug_msg "compilobj_nrep_forever gcx" gcx (the_callcount))
+  (let ( (nloc (unsafe_get_field :nrep_loc nfor))
+	 (nbind (unsafe_get_field :nforever_bind nfor))
+	 (nbody (unsafe_get_field :nforever_body nfor))
+	 (nres (unsafe_get_field :nforever_result nfor)) 
+	 (oresv (get_free_objlocptr gcx nres))
+	 )
+    (assert_msg "check nbind" (is_a nbind class_label_binding))
+    (unsafe_put_fields nbind :labind_res oresv)
+    (let ( (closy (unsafe_get_field :labind_clonsy nbind)) 
+	   (bodyl (make_list discr_list))
+	   (epilogl (make_list discr_list))
+	   (oloop (make_instance class_objloop
+				 :obi_loc nloc
+				 :oblo_bodyl bodyl
+				 :oblo_epil epilogl
+				 :obloop_label closy
+				 :obloop_resv oresv))
+	   )
+      (assert_msg "check closy" (is_a closy class_clonedsymbol))
+      (multiple_iterate 
+       nbody
+       (lambda (ncomp :long ix)
+	 (list_append bodyl (compile_obj ncomp gcx))
+	 nbody))
+      (debug_msg "compilobj loop result oloop" oloop (the_callcount))
+      oloop
+      )
+    )  
+)
+(install_method class_nrep_forever compile_obj compilobj_nrep_forever)
+
+;;;; compile an exit
+(defun compilobj_nrep_exit (nexi gcx)
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (assert_msg "check nexi" (is_a nexi class_nrep_exit))
+  (debug_msg "compilobj_nrep_exit nexi" nexi (the_callcount))
+  (debug_msg "compilobj_nrep_exit gcx" gcx (the_callcount))
+  (let ( (nloc (unsafe_get_field :nrep_loc nexi))
+	 (nbindx (unsafe_get_field :nexit_bind nexi))
+	 (nval (unsafe_get_field :nexit_val nexi)) )
+    (assert_msg "check nbindx" (is_a nbindx class_label_binding))
+    (let ( (obex (make_instance class_objexit
+				:obi_loc nloc
+				:obexit_label (unsafe_get_field :labind_clonsy nbindx)
+				:obexit_prolog (compile_obj nval gcx))) )
+      obex
+)))
+(install_method class_nrep_exit compile_obj compilobj_nrep_exit)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun compilobj_discrany (anyv gcx)
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+;  (debug_msg "compilobj_discrany anyv" anyv (the_callcount))
+  anyv
+)
+(install_method discr_anyrecv compile_obj compilobj_discrany)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun compilobj_nrep_let (rlet gcx)
+  (assert_msg "check rlet" (is_a rlet class_nrep_let))
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (let ( (loc (unsafe_get_field :nrep_loc rlet))
+	 (bnd (unsafe_get_field :nlet_bindings rlet))
+	 (bdy (unsafe_get_field :nlet_body rlet))
+	 (locmap (unsafe_get_field :gncx_locmap gcx))
+	 (obodl (make_list discr_list))
+	 (oepil (make_list discr_list))
+	 (oblock (make_instance class_objblock
+				:obi_loc loc
+				:oblo_bodyl obodl
+				:oblo_epil oepil))
+	 )
+    ;;    (debug_msg "compilobj_nrep_let rlet" rlet (the_callcount))
+    ;;    (debug_msg "compilobj_nrep_let gcx" gcx (the_callcount))
+    ;;    (debug_msg "compilobj_nrep_let bnd" bnd (the_callcount))
+    ;; for each normalexp in the bnd tuple
+    ;; add the binding and the setting in the body and the clear in the epilogue
+    (assert_msg "compilobj_nrep_let check bnd multiple" (is_multiple_or_null bnd))
+    ;; iterate on source bindings
+    (multiple_iterate 
+     bnd
+     (lambda (nlbnd :long ix)
+       ;;      (debug_msg "compilobj_nrep_let nlbnd" nlbnd (the_callcount))
+       (assert_msg "check nlbnd in compilobj_nrep_let" (is_a nlbnd class_normlet_binding))
+       (let ( (bder (unsafe_get_field :binder nlbnd))
+	      (cty (unsafe_get_field :letbind_type nlbnd))
+	      (nexp (unsafe_get_field :letbind_expr nlbnd))
+	      (obva (get_free_objloctyped gcx bder cty))
+	      (obnx (compile_obj nexp gcx))
+	      )
+	 ;;	 (debug_msg "compilobj_nrep_let obnx" obnx (the_callcount))
+	 ;; link nlbnd to obva in locmap
+	 (if obva (mapobject_put locmap nlbnd obva))
+	 ;; put destination obva in obnx
+	 (let ( (obmy (if obva (put_objdest obnx obva) obnx)) )
+	   ;; add the modified obmy in the bodypart of oblock
+	   (list_append obodl obmy)
+	   )
+	 ;; add clearing of obva to epilogue part of oblock
+	 (if obva 
+	     (let ( (obcl (make_instance class_objclear
+					 :obi_loc loc
+					 :oclr_vloc obva)) 
+		    )
+	       (list_append oepil obcl)
+	       )))
+       nlbnd ;; result of lambda in multiple_iterate
+       ))
+    ;; compile each body component
+    (multiple_iterate 
+     bdy
+     (lambda (bdycomp :long ix)
+       ;;       (debug_msg "compilobj_nrep_let bdycomp" bdycomp (the_callcount))
+       (let ( (objcomp  (compile_obj bdycomp gcx)) 
+	      )
+	 ;;	 (debug_msg "compilobj_nrep_let objcomp" objcomp (the_callcount))
+	 (list_append obodl objcomp)
+	 )
+       bdy			;result of lambda in multiple_iterate 
+       ))
+    ;; dispose each binding
+    (multiple_iterate 
+     bnd
+     (lambda (obnd :long ix)
+       (dispose_bnd_obj obnd gcx)
+       obnd))
+					;    (debug_msg "compilobj_nrep_let oblock" oblock (the_callcount))
+    oblock				;return it
+    ))
+
+(install_method class_nrep_let compile_obj compilobj_nrep_let)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun compilobj_nrep_apply (napp gcx)
+  (assert_msg "check napp" (is_a napp class_nrep_apply))
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (let ( (loc (unsafe_get_field :nrep_loc napp))
+	 (fun (unsafe_get_field :napp_fun napp))
+	 (args (unsafe_get_field :napp_args napp))
+	 )
+;    (debug_msg "compilobj_nrep_apply napp" napp (the_callcount))
+    (let ( (oclos (compile_obj fun gcx)) 
+	   (oargs (multiple_map args
+				(lambda (comp :long ix)
+				  (compile_obj comp gcx))))
+	   (oapp 
+	    (make_instance 
+	     class_objapply
+	     :obi_loc loc
+	     :obapp_dest (make_list discr_list)
+	     :obapp_clos oclos
+	     :obapp_args oargs))
+	   )
+;      (debug_msg "compilobj_nrep_apply oapp" oapp (the_callcount))
+      oapp
+      )))
+(install_method class_nrep_apply compile_obj compilobj_nrep_apply)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun putobjdest_objvalue (recv desto)
+  (assert_msg "check recv" (is_a recv class_objvalue))
+  (assert_msg "check desto" (is_a desto class_objlocv))
+  (assert_msg "check typcomp" (== (unsafe_get_field :obv_type recv) 
+				  (unsafe_get_field :obv_type desto)))
+  (let ( (destlis (make_list discr_list))
+	 (explis (make_list discr_list))
+	 (obc (make_instance class_objcompute
+			     ;; dont fill :obi_loc
+			     :obcpt_dest destlis
+			     :obcpt_expr explis
+			     )) )
+    (list_append destlis desto)
+    (list_append explis recv)
+;    (debug_msg "putobjdest objval obc" obc (the_callcount))
+    obc
+))
+
+(install_method class_objvalue  put_objdest  putobjdest_objvalue)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun putobjdest_objblock (recv desto)
+  (assert_msg "check recv" (is_a recv class_objblock))
+  (assert_msg "check desto" (is_a desto class_objlocv))
+;  (debug_msg "putobjdest block recv" recv (the_callcount))
+;  (debug_msg "putobjdest block desto" desto (the_callcount))
+  (let ( (obl (unsafe_get_field :oblo_bodyl recv))
+	 (oep (unsafe_get_field :oblo_epil recv))
+	 )
+    (assert_msg "check obl" (is_list_or_null obl))
+    (assert_msg "check oep" (is_list_or_null oep))
+    ;; maybe we should remove in the epilogue any clear of same ctype & offset
+    (let ( (lpby (list_last obl))
+	   (lasbp (pair_head lpby))
+	   )
+      (if lasbp 
+	  (let ( (uplasb (put_objdest lasbp desto)) )
+	    (pair_set_head lpby uplasb)
+	    )
+	)
+      )
+;    (debug_msg "putobjdest block updated recv" recv (the_callcount))
+    recv
+    ))
+
+(install_method class_objblock  put_objdest  putobjdest_objblock)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun putobjdest_objloop (recv desto)
+  (assert_msg "check recv" (is_a recv class_objloop))
+  (assert_msg "check desto" (is_a desto class_objlocv))
+  (let ( (epil (unsafe_get_field :oblo_epil recv)) 
+	 (resv (unsafe_get_field :obloop_resv recv))
+	 (obc (make_instance class_objcompute
+			     ;; dont fill :obi_loc
+			     :obcpt_dest desto
+			     :obcpt_expr resv
+			     ))
+	 )
+    (assert_msg "check epil" (is_list epil))
+    (assert_msg "check resv" (is_a resv class_objlocv))
+    (list_append epil obc)
+    )
+  ;;    (debug_msg "putobjdest loop updated recv" recv (the_callcount))
+  recv
+  )
+(install_method class_objloop  put_objdest  putobjdest_objloop)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun putobjdest_objexit (recv desto)
+  (assert_msg "check recv" (is_a recv class_objexit))
+  (assert_msg "check desto" (is_a desto class_objlocv))
+  (let ( (oxpro (unsafe_get_field :obexit_prolog recv)) 
+	 (npro (put_objdest oxpro desto)) )
+    (if (!= npro oxpro)
+	(unsafe_put_fields recv :obexit_prolog npro))
+    recv
+))
+(install_method class_objexit put_objdest putobjdest_objexit)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; put a destination inside a raw object allocation
+(defun putobjdest_objrawallocobj (recv desto)
+  (assert_msg "check recv" (is_a recv class_objrawallocobj))
+  (list_append (unsafe_get_field :obrallobj_dest recv) desto)
+  recv
+)
+(install_method class_objrawallocobj put_objdest putobjdest_objrawallocobj)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; put a destination inside a closure allocation
+(defun putobjdest_objnewclosure (recv desto)
+  (assert_msg "check recv" (is_a recv class_objnewclosure))
+  (list_append (unsafe_get_field :obnclo_dest recv) desto)
+  recv
+)
+(install_method class_objnewclosure put_objdest putobjdest_objnewclosure)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun compilobj_nrep_if (rif gcx)
+  (assert_msg "check rif" (is_a rif class_nrep_if))
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (let ( (loc (unsafe_get_field :nrep_loc rif))
+	 (ntest (unsafe_get_field :nif_test rif))
+	 (nthen (unsafe_get_field :nif_then rif))
+	 (nelse (unsafe_get_field :nif_else rif))
+	 (nctyp (unsafe_get_field :nif_ctyp rif))
+	 )
+    (assert_msg "check nctyp" (is_a nctyp class_ctype))
+    (let ( (otest (compile_obj ntest gcx))
+	   (othen (compile_obj nthen gcx))
+	   (oelse (compile_obj nelse gcx))
+	   (obif (make_instance class_objcond
+				:obi_loc loc
+				:obcond_test otest
+				:obcond_then othen
+				:obcond_else oelse))
+	   )
+;      (debug_msg "compilobj_nrep_if obif" obif (the_callcount))
+      obif
+      )))
+(install_method class_nrep_if compile_obj compilobj_nrep_if)
+;;;;;;;;;;;;;
+(defun putobjdest_objcond (recv desto)
+;  (debug_msg "putobjdest objcond recv" recv (the_callcount))
+;  (debug_msg "putobjdest objcond desto" desto (the_callcount))
+  (assert_msg "check recv" (is_a recv class_objcond))
+  (assert_msg "check desto" (is_a desto class_objlocv))
+  (let ( (othen (unsafe_get_field :obcond_then recv))
+	 (oelse (unsafe_get_field :obcond_else recv)) 
+	 )
+ ;   (debug_msg "putobjdest objcond othen" othen (the_callcount))
+ ;   (debug_msg "putobjdest objcond oelse" oelse (the_callcount))
+    (let ( (dthen (put_objdest othen desto))
+	   (delse (put_objdest oelse desto)) )
+;      (debug_msg "putobjdest objcond dthen" dthen (the_callcount))
+;      (debug_msg "putobjdest objcond delse" delse (the_callcount))
+      (unsafe_put_fields recv
+			 :obcond_then dthen
+			 :obcond_else delse)
+;      (debug_msg "putobjdest objcond updated recv" recv (the_callcount))
+      recv
+      )))
+
+(install_method class_objcond  put_objdest  putobjdest_objcond)
+;;;;;;;;;;;;;;;;
+(defun putobjdest_objapply (recv desto)
+  (debug_msg "putobjdest objapply recv" recv (the_callcount))
+;  (debug_msg "putobjdest objapply desto" desto (the_callcount))
+  (assert_msg "check recv" (is_a recv class_objapply))
+  (assert_msg "check desto" (is_a desto class_objlocv))
+  (let ( (adest (unsafe_get_field :obapp_dest recv)) )
+    (assert_msg "check adest" (is_list adest))
+    (list_prepend adest desto)
+    recv
+))
+(install_method class_objapply put_objdest putobjdest_objapply)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+(defun compilobj_nrep_return (nret gcx)
+  (assert_msg "check nret" (is_a nret class_nrep_return))
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+;  (debug_msg "compilobj_nrep_return gcx" gcx (the_callcount))
+;  (debug_msg "compilobj_nrep_return nret" nret (the_callcount))
+  (let ( (rloc (unsafe_get_field :nrep_loc nret))
+	 (rmain (unsafe_get_field :nret_main nret))
+	 (rrest (unsafe_get_field :nret_rest nret)) ;; a tuple or nil
+	 (retloc (unsafe_get_field :gncx_retloc gcx))
+	 (orout (unsafe_get_field :gncx_objrout gcx))
+	 (olis (make_list discr_list))
+	 (oblock (make_instance class_objblock
+				:obi_loc rloc
+				:oblo_bodyl olis))
+	 (omainv (compile_obj rmain gcx))
+	 )
+    (assert_msg "check orout" (is_a orout class_routineobj))
+    (if (null (unsafe_get_field :obrout_retval orout))
+	(unsafe_put_fields orout :obrout_retval retloc))
+    (list_append olis (put_objdest omainv retloc))
+    (multiple_iterate 
+     rrest
+     (lambda (rxtra :long ix)
+;       (debug_msg "compilobj_nrep_return rxtra" rxtra (the_callcount))
+       (let ( (oxres 
+	       (make_instance class_objputxtraresult
+			      :obi_loc rloc
+			      :obxres_rank (make_integerbox discr_integer ix)
+			      :obxres_obloc (compile_obj rxtra gcx))) )
+	 ;; maybe we need to compute the ctype of the extra result....
+;	 (debug_msg "compilobj_nrep_return oxres" oxres (the_callcount))
+	 (list_append olis oxres)
+	 )
+       rrest			;return of lamda to continue iteration
+       )
+     )
+    (list_append olis 
+		 (make_instance class_objfinalreturn
+				:obi_loc rloc))
+;    (debug_msg "compilobj_nrep_return final oblock" oblock (the_callcount))
+    oblock
+    )
+  )
+(install_method class_nrep_return compile_obj compilobj_nrep_return)
+
+;; all the closures generated by lambda share the same ...
+(definstance discrclosure_objpredef class_objpredef
+  :obv_type ctype_value
+  :obpredef 'DISCR_CLOSURE
+  )
+
+(defun compilobj_nrep_lambda (nlam gcx)
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (assert_msg "check nlam" (is_a nlam class_nrep_lambda))
+  (debug_msg "compilobj_nrep_lambda nlam" nlam (the_callcount))
+  (let ( (nloc (unsafe_get_field :nrep_loc nlam))
+	 (npro (let 
+		   ( (checkpro (unsafe_get_field :nlambda_proc nlam)) )
+		 (assert_msg "check checkpro" (is_a checkpro class_nrep_routproc))
+		 checkpro))
+	 (nam (unsafe_get_field :nrpro_name npro))
+	 (nclovtup (unsafe_get_field :nlambda_closedv nlam))
+	 (:long nbclosed (multiple_length nclovtup))
+	 (locv (get_free_objlocptr gcx nam))
+	 (nrou (unsafe_get_field :nlambda_constrout nlam))
+	 (orout (unsafe_get_field :gncx_objrout gcx))
+	 (olis (make_list discr_list))
+	 (oblock (make_instance class_objblock
+				:obi_loc nloc
+				:oblo_bodyl olis))
+	 (destlist (make_list discr_list))
+	 )
+    (list_append destlist locv)
+    (list_append olis 
+		 (make_instance 
+		  class_objnewclosure
+		  :obi_loc nloc
+		  :obnclo_discr discrclosure_objpredef
+		  :obnclo_rout 
+		  (progn 
+		    (debug_msg "compilobj_nrep_lambda should use nrpro_thunklist nrou" nrou (the_callcount))
+		    (let ( (crou (compile_obj nrou gcx)) )
+		      (debug_msg "compilobj_nrep_lambda crou" crou (the_callcount))
+		      crou)
+		  )
+		  :obnclo_len (make_integerbox discr_integer nbclosed)
+		  :obnclo_dest destlist))
+    (multiple_iterate
+     nclovtup
+     (lambda (clov :long ix)
+       (debug_msg "compilobj_nrep_lambda clov" clov)
+       (list_append 
+	olis
+	(make_instance class_objputclosedv
+		       :obi_loc nloc
+		       :opclov_clos locv
+		       :opclov_off (make_integerbox discr_integer ix)
+		       :opclov_cval (compile_obj clov gcx)))       
+       nclovtup
+       ))
+    (list_append olis locv) ;;; last instruction is just the value, which can be set to some dest
+    (debug_msg "compilobj_nrep_lambda result oblock" oblock (the_callcount))
+    oblock
+    ))
+(install_method class_nrep_lambda compile_obj compilobj_nrep_lambda)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; compile a procedure should not be called
+(defun compilobj_routproc (npro gcx)
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (assert_msg "check npro" (is_a npro class_nrep_routproc))
+  (debug_msg "compilobj_routproc gcx" gcx (the_callcount))
+  (debug_msg "compilobj_routproc npro" npro (the_callcount))
+  (assert_msg "UNEXPECTED CALL TO compilobj_routproc" ())
+)
+(install_method class_nrep_routproc compile_obj compilobj_routproc)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+(defun compilobj_predef (npr gcx)
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+;  (debug_msg "compilobj_predef npr" npr (the_callcount))
+  (let ( (opr (make_instance class_objpredef
+			     :obv_type ctype_value
+			     :obpredef (unsafe_get_field :nrpredef npr))) )
+;    (debug_msg "compilobj_predef opr" opr (the_callcount))
+    opr)
+)
+
+(install_method class_nrep_predef compile_obj compilobj_predef)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; common code to compilobj_datasymbol & compilobj_datainstance
+;;; to add the initial data fill and the slots filling
+(defun compil_data_and_slots_fill (ndat obj odiscr irout gcx)
+  (assert_msg "compil_data_and_slots_fill check ndat" (is_a ndat class_nrep_data))
+  (assert_msg "compil_data_and_slots_fill check obj" (is_a obj class_objinitobject))
+  (assert_msg "compil_data_and_slots_fill check odiscr" (is_a odiscr class_objvalue))
+  (assert_msg "compil_data_and_slots_fill check irout" (is_a irout class_initialroutineobj))
+  (assert_msg "compil_data_and_slots_fill check gcx" (is_a gcx class_genercontext))
+;;  (debug_msg "compil_data_and_slots_fill ndat" ndat (the_callcount))
+;;  (debug_msg "compil_data_and_slots_fill obj" obj (the_callcount))
+;;  (debug_msg "compil_data_and_slots_fill odiscr" odiscr (the_callcount))
+;;  (debug_msg "compil_data_and_slots_fill irout un" irout (the_callcount))
+  (let (
+	(ibodylis (unsafe_get_field :obrout_body irout))
+	(ifilllis (unsafe_get_field :oirout_fill irout))
+	(locvar (get_free_objlocptr gcx '_valdata_))
+	(comm (unsafe_get_field :named_name '_valuedata_))
+	(nloc (unsafe_get_field :nrep_loc ndat))
+	)
+    (assert_msg "compil_data_and_slots_fill check ibodylis" (is_list ibodylis))
+    (assert_msg "compil_data_and_slots_fill check fresh obj" (null (unsafe_get_field :oie_locvar obj)))
+    (unsafe_put_fields obj :oie_locvar locvar)
+    (assert_msg "check ifilllis" (is_list ifilllis))
+    (assert_msg "check ibodylis" (is_list ibodylis))
+    ;; for every non nil slot, append its initialization to the body of irout
+    (multiple_iterate
+     (unsafe_get_field :ninst_slots ndat)
+     (lambda (sloval :long slork)
+       ;;  (debug_msg "compil_data_and_slots_fill sloval" sloval (the_callcount))
+       (if sloval
+	   (let ( (slobj (compile_obj sloval gcx)) 
+		  )
+	     ;; (debug_msg "compil_data_and_slots_fill slobj" slobj (the_callcount))
+	     (let ( (oput 
+		     (make_instance class_objputslot
+				    :obi_loc  nloc
+				    :oslot_odata obj
+				    :oslot_offset (make_integerbox discr_integer slork)
+				    :oslot_value slobj
+				    )) )
+	       (list_append ibodylis oput)
+	       )
+	     )
+;;; add to list inifill the filling in dai of slot#slork by slobj
+	 )
+       )
+     ndat				;return in iteration 
+     )
+    (list_append ibodylis 
+		 (make_instance class_objtouch
+				:obi_loc  nloc
+				:obi_loc (unsafe_get_field :nrep_loc ndat)
+				:otouch_comment comm
+				:otouch_val obj))
+    )
+;;  (debug_msg "compil_data_and_slots_fill final irout" irout (the_callcount))
+  (return)				;force a nil return
+  )
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun compilobj_datasymbol (syv gcx)
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (assert_msg "check syv" (is_a syv class_nrep_datasymbol))
+  (debug_msg "compilobj_datasymbol syv" syv (the_callcount))
+  (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) 
+	 (chobj (mapobject_get compicache syv))
+	 (inirout (unsafe_get_field :gncx_objrout gcx))
+	 )
+    ;; datasymbol compiled only in initial routines
+    (assert_msg "check inirout" (is_a inirout class_initialroutineobj))
+    (if chobj
+	(progn
+	  (debug_msg "compilobj_datasymbol found chobj" chobj)
+	  (return chobj)))
+    (let (
+	  (odiscr  (compile_obj (unsafe_get_field :ndata_discrx syv) gcx))
+	  (obsym 
+	   (make_instance class_objinitobject
+			  :obv_type ctype_value
+			  :oie_data syv
+			  :oie_discr odiscr
+			  )) 
+	  )
+      (mapobject_put compicache syv obsym)
+      (debug_msg "compilobj_datasymbol inirout" inirout (the_callcount))
+      ;; make a cname
+      (let ( (nambuf (make_strbuf discr_strbuf))
+	     (:long syrk (get_int (unsafe_get_field :ndata_rank syv)))
+	     )
+	(add2sbuf_strconst nambuf "dsym_")
+	(add2sbuf_longdec nambuf syrk)
+	(add2sbuf_strconst nambuf "__")
+	(add2sbuf_cident nambuf (unsafe_get_field :ndsy_namestr syv))
+	(unsafe_put_fields obsym
+			   :oie_cname (strbuf2string discr_string nambuf)))
+      ;; put the length as obj_num of obsym
+      (put_int obsym (multiple_length (unsafe_get_field :ninst_slots syv)))
+      (debug_msg "compilobj_datasymbol gcx" gcx (the_callcount))
+      (debug_msg "compilobj_datasymbol obsym beforfill" obsym (the_callcount))
+      (compil_data_and_slots_fill syv obsym odiscr inirout gcx)
+      (debug_msg "compilobj_datasymbol obsym final" obsym (the_callcount))
+      obsym
+      )))
+(install_method class_nrep_datasymbol compile_obj compilobj_datasymbol)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;; compilobj of datainstance
+(defun compilobj_datainstance (dai gcx)
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (debug_msg "compilobj_datainstance gcx" gcx (the_callcount))
+  (debug_msg "compilobj_datainstance dai" dai (the_callcount))
+  (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) 
+	 (chobj (mapobject_get compicache dai))
+	 (inirout (unsafe_get_field :gncx_objrout gcx))
+	 )
+    ;; datainstance compiled only in initial routines
+    (assert_msg "check inirout" (is_a inirout class_initialroutineobj))
+    (if chobj
+	(progn
+	  (debug_msg "compilobj_datainstance found chobj" chobj)
+	  (return chobj)))
+    (let ( (loc (unsafe_get_field :nrep_loc dai))
+	   (nam (unsafe_get_field :ndata_name dai))
+	   ;; nam is a symbol, not a string
+	   (disx (unsafe_get_field :ndata_discrx dai))
+	   (drank (unsafe_get_field :ndata_rank dai))
+	   (dhash (unsafe_get_field :ninst_hash dai))
+	   (dslots (unsafe_get_field :ninst_slots dai)) 
+	   (ininsl (unsafe_get_field :ninit_topl inirout))
+	   (inifill (unsafe_get_field :oirout_fill inirout))
+	   )
+      ;; if the drank is invalid or nil, the data has never been added
+      ;; with add_nctx_data (should not happen)
+      (assert_msg "compilobj_datainstance check drank" (is_integerbox drank))
+      (debug_msg "compilobj_datainstance disx" disx (the_callcount))
+      (debug_msg "compilobj_datainstance avant gcx" gcx (the_callcount))
+      (let ( (cdisx (compile_obj disx gcx)) 
+	     )
+	(debug_msg "compilobj_datainstance cdisx" cdisx (the_callcount))
+	(let (
+	      ;; make a cname
+	      (oini (make_instance class_objinitobject
+				   :obv_type ctype_value
+				   :oie_data dai
+				   :oie_discr cdisx))
+	      (nambuf (make_strbuf discr_strbuf))
+	      (:long drk (get_int drank))
+	      )
+	  (mapobject_put compicache dai oini)
+	  (add2sbuf_strconst nambuf "dobj_")
+	  (add2sbuf_longdec nambuf drk)
+	  (if nam (progn
+		    (add2sbuf_strconst nambuf "__")
+		    (add2sbuf_cident nambuf (unsafe_get_field :named_name nam))))
+	  (let ( (cnam (strbuf2string discr_string nambuf)) )
+	    (unsafe_put_fields oini :oie_cname cnam)
+	    (debug_msg "compilobj_datainstance cnam" cnam (the_callcount))
+	    )
+	  (put_int oini (multiple_length dslots))
+	  (debug_msg "compilobj_datainstance apres gcx" gcx (the_callcount))
+	  (debug_msg "compilobj_datainstance oini" oini (the_callcount))
+	  (compil_data_and_slots_fill dai oini cdisx inirout gcx)
+	  (debug_msg "compilobj_datainstance final oini" oini (the_callcount))
+	  oini
+	  )  
+	)
+      )
+    )
+  )
+(install_method class_nrep_datainstance compile_obj compilobj_datainstance)
+  
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;; compile a data tuple
+(defun compilobj_datatuple (nti gcx)
+  (assert_msg "check nti" (is_a nti class_nrep_datatuple))
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (debug_msg "compilobj_datatuple gcx" gcx (the_callcount))
+  (debug_msg "compilobj_datatuple nti" nti (the_callcount))
+  (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) 
+	 (chobj (mapobject_get compicache nti))
+	 (inirout (unsafe_get_field :gncx_objrout gcx))
+	 )
+    ;; datatuples compiled only in initial routines
+    (assert_msg "check inirout" (is_a inirout class_initialroutineobj))
+    (if chobj
+	(progn
+	  (debug_msg "compilobj_datatuple found chobj" chobj)
+	  (return chobj)))
+    (let ( (ncompi (unsafe_get_field :ntup_comp nti))
+	   (disx (unsafe_get_field :ndata_discrx nti))
+	   (drank (unsafe_get_field :ndata_rank nti))
+	   (odiscr (compile_obj disx gcx)) 
+	   (nam (unsafe_get_field :ndata_name nti))
+	   (nambuf (make_strbuf discr_strbuf))
+	   (locvar (get_free_objlocptr gcx '_valtup_))
+	   (:long drk (get_int drank))
+	   (inibody (unsafe_get_field :obrout_body inirout))
+	   (comm (unsafe_get_field :named_name '_initup_))
+	   )
+      (add2sbuf_strconst nambuf "dtup_")
+      (add2sbuf_longdec nambuf drk)
+      (if nam (progn
+		(add2sbuf_strconst nambuf "__")
+		(add2sbuf_cident nambuf (unsafe_get_field :named_name nam))))
+      (let ( (otup (make_instance class_objinitmultiple
+				  :obv_type ctype_value
+				  :oie_discr odiscr
+				  :oie_locvar locvar
+				  :oie_cname (strbuf2string discr_string nambuf)
+				  ))
+	     )
+	(mapobject_put compicache nti otup)
+	(put_int otup (multiple_length ncompi))
+	(multiple_iterate
+	 ncompi
+	 (lambda (scomp :long srk)
+	   (if scomp 
+	       (let ( (ocomp (compile_obj scomp gcx)) )
+		 (list_append inibody
+			      (make_instance class_objputuple
+					     :oputu_tupled otup
+					     :oputu_offset (make_integerbox discr_integer srk)
+					     :oputu_value ocomp)))
+	     )
+	   ncompi
+	   ))
+	(list_append inibody
+		     (make_instance class_objtouch
+				    :otouch_val otup
+				    :otouch_comment comm))
+	(debug_msg "compilobj datatuple otup" otup (the_callcount))
+	otup
+	)
+      )
+    )
+  )
+  
+(install_method class_nrep_datatuple compile_obj compilobj_datatuple)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;; compile a data string
+(defun compilobj_datastring (nds gcx)
+  (assert_msg "check nds" (is_a nds class_nrep_datastring))
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (debug_msg "compilobj_datastring gcx" gcx (the_callcount))
+  (debug_msg "compilobj_datastring nds" nds (the_callcount))
+  (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) 
+	 (inirout (unsafe_get_field :gncx_objrout gcx))
+	 (chobj (mapobject_get compicache nds))
+	 )
+    ;; datastring compiled only in initial routines
+    (assert_msg "check inirout" (is_a inirout class_initialroutineobj))
+    (if chobj
+	(progn
+	  (debug_msg "compilobj_datastring found chobj" chobj)
+	  (return chobj)))
+    (let (
+	  (nambuf (make_strbuf discr_strbuf))
+	  (ndisx (unsafe_get_field :ndata_discrx nds))
+	  (odiscr (compile_obj ndisx gcx))
+	  (odata (unsafe_get_field :nstr_string nds))
+	  (drank (unsafe_get_field :ndata_rank nds))
+	  (nam (unsafe_get_field :ndata_name nds))
+	  (locvar (get_free_objlocptr gcx '_valstr_))
+	  (:long drk (get_int drank))
+	  (ostr (make_instance class_objinitstring
+			       :oie_data odata
+			       :oie_discr odiscr
+			       :oie_locvar locvar
+			       )) 
+	  )
+      (mapobject_put compicache nds ostr)
+      (add2sbuf_strconst nambuf "dstr_")
+      (add2sbuf_longdec nambuf drk)
+      (add2sbuf_strconst nambuf "__")
+      (add2sbuf_cidentprefix nambuf odata 16)
+      (put_int ostr (string_length odata))
+      (if nam 
+	  (progn
+	    (add2sbuf_strconst nambuf "__")
+	    (add2sbuf_cident nambuf (unsafe_get_field :named_name nam))))
+      (unsafe_put_fields ostr :oie_cname (strbuf2string discr_string nambuf))
+      (debug_msg "compilobj_datastring ostr" ostr (the_callcount))
+      ostr
+      )
+    ))
+(install_method class_nrep_datastring compile_obj compilobj_datastring)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;; compile a data closure
+(defun compilobj_dataclosure (ncl gcx)
+  (assert_msg "check ncl" (is_a ncl class_nrep_dataclosure))
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (debug_msg "compilobj_dataclosure gcx" gcx (the_callcount))
+  (debug_msg "compilobj_dataclosure ncl" ncl (the_callcount))
+  (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) 
+	 (inirout (unsafe_get_field :gncx_objrout gcx))
+	 (inibody (unsafe_get_field :obrout_body inirout))
+	 (chobj (mapobject_get compicache ncl))
+	 )
+    (assert_msg  "check inirout" (is_a inirout class_initialroutineobj))
+    (if chobj
+	(progn
+	  (debug_msg "compilobj_dataclosure found chobj" chobj)
+	  (return chobj)))
+    (let ( 
+	  (nam (unsafe_get_field :ndata_name ncl))
+	  (discx (unsafe_get_field :ndata_discrx ncl))
+	  (nrank (unsafe_get_field :ndata_rank ncl))
+	  (nloc (unsafe_get_field :nrep_loc ncl))
+	  (npro (unsafe_get_field :ndclo_proc ncl))
+	  (nclov (unsafe_get_field :ndclo_closv ncl))
+	  (:long nbclos (multiple_length nclov))
+	  (nambuf (make_strbuf discr_strbuf))
+	  (odiscr (compile_obj discx gcx))
+	  (locvar (get_free_objlocptr gcx '_valclo_))
+	  (comm (unsafe_get_field :named_name '_dataclosure_))
+	  )
+      (assert_msg "check npro" (is_a npro class_nrep_routproc))
+      (add2sbuf_strconst nambuf "dclo_")
+      (add2sbuf_longdec nambuf (get_int nrank))
+      (if nam (progn
+		(add2sbuf_strconst nambuf "__")
+		(add2sbuf_cident nambuf (unsafe_get_field :named_name nam))))
+					;    (debug_msg "compilobj_dataclosure encore ncl" ncl (the_callcount))
+      (let (
+	    (ndatarou (unsafe_get_field :nrpro_datarout npro))
+	    (oiclo
+	     (make_instance class_objinitclosure
+			    :obv_type ctype_value
+			    :oie_discr odiscr
+			    :oie_data ncl
+			    :oie_locvar locvar
+			    :oie_cname (strbuf2string discr_string nambuf)
+			    )) 
+	    )
+	(put_int oiclo nbclos)
+	(mapobject_put compicache ncl oiclo)
+	(assert_msg "check ndatarou" (is_a ndatarou class_nrep_dataroutine))
+	(let (
+	      ;; npro should already have been compiled, so should be in the compiler cache
+	      (ocrout (mapobject_get compicache npro))
+	      (ocputrout (make_instance  class_objputclosurout
+					 :obi_loc nloc
+					 :opclor_clos oiclo
+					 :opclor_rout (mapobject_get compicache ndatarou)))
+	      (bxoff (make_integerbox discr_integer 0))
+	      )
+	  (assert_msg "check ocrout" (is_a ocrout class_procroutineobj))
+	  (list_append inibody ocputrout)
+	  (debug_msg "compilobj_dataclosure nclov" nclov (the_callcount))
+	  (multiple_iterate 
+	   nclov
+	   (lambda (clov :long ix)
+	     (let ( (cloval (compile_obj clov gcx)) 
+		    (ocputclos (make_instance class_objputclosedv
+					      :obi_loc nloc
+					      :opclov_clos oiclo
+					      :opclov_off (make_integerbox discr_integer (get_int bxoff))
+					      :opclov_cval cloval))
+		    )
+	       (list_append inibody ocputclos)
+	       )
+	     (put_int bxoff (+i (get_int bxoff) 1))
+	      nclov
+	     )
+	   )
+	  (list_append inibody (make_instance class_objtouch
+					      :obi_loc nloc
+					      :otouch_comment comm
+					      :otouch_val oiclo))
+	  oiclo
+	  ))
+      ))
+  )
+(install_method class_nrep_dataclosure compile_obj compilobj_dataclosure)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;; compile a data routine
+(defun compilobj_dataroutine (ndrou gcx)
+  (assert_msg "check ndrou" (is_a ndrou class_nrep_dataroutine))
+  (assert_msg "check gcx" (is_a gcx class_genercontext))
+  (debug_msg "compilobj_dataroutine+ gcx" gcx (the_callcount))
+  (debug_msg "compilobj_dataroutine+ ndrou" ndrou (the_callcount))
+  (shortbacktrace_dbg "compilobj_dataroutine+" 12)
+  (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) 
+	 (inirout (unsafe_get_field :gncx_objrout gcx))
+	 (chobj (mapobject_get compicache ndrou))
+	 )
+    ;; dataroutine compiled only in initial routines
+    (assert_msg "check inirout" (is_a inirout class_initialroutineobj))
+    (if chobj
+	(progn
+	  (debug_msg "compilobj_dataroutine+ found chobj" chobj)
+	  (return chobj)))
+    (let ( (nam (unsafe_get_field :ndata_name ndrou))
+	   (disx (unsafe_get_field :ndata_discrx ndrou))
+	   (nloc (unsafe_get_field :nrep_loc ndrou))
+	   (drank (unsafe_get_field :ndata_rank ndrou))
+	   (nam (unsafe_get_field :ndata_name ndrou))
+	   (npro (unsafe_get_field :ndrou_proc ndrou))
+	   (inibody (unsafe_get_field :obrout_body inirout))
+	   (locvar (get_free_objlocptr gcx '_valrout_))
+	   )
+      (assert_msg "check compicache" (is_mapobject compicache))
+      (let (
+	    (nambuf (make_strbuf discr_strbuf))
+	    (:long drk (get_int drank))
+	    (odiscr (compile_obj disx gcx))
+	    )
+	(add2sbuf_strconst nambuf "drout_")
+	(add2sbuf_longdec nambuf drk)
+	(if nam (progn
+		  (add2sbuf_strconst nambuf "__")
+		  (add2sbuf_cident nambuf (unsafe_get_field :named_name nam))))
+	(debug_msg "compilobj_dataroutine encore ndrou" ndrou (the_callcount))
+	(let (
+	      (oirout 
+	       (make_instance class_objinitroutine
+			      :obv_type ctype_value
+			      :oie_discr odiscr
+			      :oie_data ndrou
+			      :oie_locvar locvar
+			      :oie_cname (strbuf2string discr_string nambuf)
+			      :oir_procroutine (mapobject_get compicache npro)
+			      )) 
+	      )
+	  (mapobject_put compicache ndrou oirout)
+	  (debug_msg "compilobj_dataroutine+ npro" npro (the_callcount))
+	  (if (is_a npro class_nrep_routproc)
+	      (let ( (pconstl (unsafe_get_field :nrpro_const npro)) 
+		     (:long nbconst (list_length pconstl))
+		     (bxoff (make_integerbox discr_integer 0))
+		     (comm (unsafe_get_field :named_name '_iroutval_))
+		     )
+		(debug_msg "compilobj_dataroutine pconstl" pconstl (the_callcount))
+		(put_int oirout nbconst)
+		(list_iterate
+		 pconstl
+		 (lambda (constx)
+		   (let ( (oconstx (compile_obj constx gcx)) 
+			  (:long off (get_int bxoff))
+			  ) 
+		     (if oconstx 
+			 (let ( (iput (make_instance class_objputroutconst
+						     :obi_loc nloc
+						     :oprconst_rout oirout
+						     :oprconst_off (make_integerbox discr_integer off)
+						     :oprconst_cval oconstx)) ) 
+			   (list_append inibody iput)
+			   (put_int bxoff (+i off 1))))
+		     )
+		   pconstl
+		   )
+		 )
+		(if (>i (get_int bxoff) 0)
+		    (list_append inibody (make_instance class_objtouch
+							:obi_loc nloc
+							:otouch_val oirout
+							:otouch_comment comm
+							)))
+		)
+	    )
+	  (debug_msg "compilobj_dataroutine here npro" npro (the_callcount))
+	  (debug_msg "compilobj_dataroutine here fresh oirout" oirout (the_callcount))
+	  oirout)
+	))))
+(install_method class_nrep_dataroutine compile_obj compilobj_dataroutine)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;; initial commands
+(definstance initial_command_dispatcher class_command_dispatcher
+  :predef INITIAL_COMMAND_DISPATCHER
+  :named_name (stringconst2val discr_namestring "INITIAL_COMMAND_DISPATCHER")
+  :cmd_fundict  (make_mapstring discr_mapstrings 40)
+)
+
+(defun install_initial_command (nam fun)
+  (if (is_closure fun)
+      (if (is_string nam)
+	  (mapstring_putstr (unsafe_get_field :cmd_fundict initial_command_dispatcher) 
+			    nam fun))))
+;;;;
+(defun readseq_command (dispatcher arg)
+  (message_dbg "starting readseq")
+  (debug_msg "start readseq_command" arg (the_callcount))
+  (let ( (rlist (read_file arg)) )
+    (message_dbg "ending readseq")
+    (debug_msg "done readseq_command" rlist (the_callcount))
+))
+
+(install_initial_command  (stringconst2val discr_string "readseq") readseq_command)
+
+;;;;
+
+(defun expandseq_command (dispatcher arg)
+  (message_dbg "starting expandseq")
+  (debug_msg "start expandseq_command" arg (the_callcount))
+  (debug_msg "start expandseq_command initial_environment" initial_environment (the_callcount))
+  (debug_msg "start expandseq_command class_root" class_root (the_callcount))
+  (debug_msg "start expandseq_command class_class" class_class (the_callcount))
+  (debug_msg "start expandseq_command class_field" class_field (the_callcount))
+  (let ( (rlist (read_file arg)) 
+	 (inienv initial_environment) ) 
+    (debug_msg "after read expandseq_command rlist" rlist (the_callcount))
+    (debug_msg "after read expandseq_command inienv" inienv (the_callcount))
+    (let ( (xlist (macroexpand_toplevel_list rlist inienv)) )
+      (debug_msg "after macroexpansion expandseq_command seq" xlist (the_callcount))
+      (debug_msg "after macroexpansion expandseq_command inienv" inienv (the_callcount))
+      )))
+
+(install_initial_command  (stringconst2val discr_string "expandseq") expandseq_command)
+;;;;
+
+(defun normexpseq_command (dispatcher arg)
+  (message_dbg "starting normexpseq_command")
+  (debug_msg "start normexpseq_command" arg (the_callcount))
+  (let ( (rlist (read_file arg)) ) 
+    (debug_msg "after read normexpseq_command rlist" rlist (the_callcount))
+    (debug_msg "after read normexpseq_command initial_environment" initial_environment (the_callcount))
+    (let ( (xlist (macroexpand_toplevel_list rlist initial_environment)) )
+      (debug_msg "after macroexpand normexpseq_command xlist" xlist (the_callcount))
+      (debug_msg "after macroexpand normexpseq_command initial_environment" initial_environment (the_callcount))
+      (let ( (ncx (create_normcontext)) )
+ 	(debug_msg "before normalization normexpseq_command ncx" ncx (the_callcount))
+ 	(list_iterate 
+ 	 xlist
+ 	 (lambda (sexp :long ix)
+ 	   (debug_msg "normexpseq_command sexp" sexp (the_callcount))
+ 	   (let (
+		 (psloc (if (is_a sexp class_located) (unsafe_get_field :loca_location sexp)))
+		 (nexp
+ 		   (normal_exp sexp initial_environment ncx psloc)) )
+ 	     (debug_msg "normexpseq_command nexp" nexp (the_callcount))
+ 	     )))
+ 	(debug_msg "after normalization normexpseq_command ncx" ncx (the_callcount))
+ 	)))
+  )
+
+(install_initial_command  (stringconst2val discr_string "normexpseq") normexpseq_command)
+
+;;;;;
+(defun compileseq_command (dispatcher arg)
+  (message_dbg "starting compileseq_command")
+  (debug_msg "start compileseq_command" arg (the_callcount))
+  (let ( (rlist (read_file arg)) 
+	 (basnam (make_string_nakedbasename discr_string arg))
+	 ) 
+    (debug_msg "after read compileseq_command rlist" rlist (the_callcount))
+    (debug_msg "after read compileseq_command initial_environment" initial_environment (the_callcount))
+    (compile_list_sexpr rlist initial_environment basnam)
+    ))
+
+(install_initial_command  (stringconst2val discr_string "compileseq") compileseq_command)
+;;; eof warm-basilys.bysl
\ No newline at end of file
diff --git a/gcc/run-basilys.h b/gcc/run-basilys.h
index 80c728f93f1..ab65e65725c 100644
--- a/gcc/run-basilys.h
+++ b/gcc/run-basilys.h
@@ -23,27 +23,26 @@ the Free Software Foundation, 51 Franklin Street, Fifth Floor,
 Boston, MA 02110-1301, USA.  */
 
 
+/* usual GCC middle-end includes, copied from ipa-cp.c */
 
 #include "config.h"
 #include "system.h"
 #include "coretypes.h"
-#include "obstack.h"
-#include "tm.h"
+#include "real.h"
 #include "tree.h"
+#include "target.h"
+#include "cgraph.h"
+#include "ipa-prop.h"
+#include "tree-flow.h"
 #include "tree-pass.h"
-#include "tree-dump.h"
-#include "basic-block.h"
+#include "flags.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 "tree-dump.h"
+#include "tree-inline.h"
+
+
+/* basilys or MELT specific includes */
 
 #include "compiler-probe.h"