2015-06-12 Basile Starynkevitch <basile@starynkevitch.net>

[official-gcc.git] / gcc / melt / warmelt-normal.melt

;; file warmelt-normal.melt -*- Lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(comment "***
    Copyright 2008 - 2014  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/>.
***")

;; the copyright notice above apply both to warmelt-normal.melt and 
;; to the generated file  warmelt-normal*.c


;; This MELT module is GPL compatible since it is GPLv3+ licensed.
(module_is_gpl_compatible "GPLv3+")

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

;;    This file is part of a bootstrapping compiler for the MELT lisp
;;    dialect, compiler which should be able to compile itself (into
;;    generated C file[s])
;;    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;; ================ 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

;;; common superclass for normalized representations
(defclass class_nrep
  :super class_root
  :doc #{The $CLASS_NREP is the common super class of normalized
representations. Its $NREP_LOC field gives the location in source,
if any.}#
  :fields (nrep_loc                     ;location in source
           ))


;;; the discriminant for normalizing closures
(definstance discr_normalizing_closure class_discriminant
  :doc #{The $DISCR_NORMALIZING_CLOSURE is the discriminant of MELT debug
  functions. Use $CLONE_WITH_DISCRIMINANT on a closure, e.g. with
  $LAMBDA, to make it a normalizing function. For gurus.}#
  :obj_num MELTOBMAG_CLOSURE
  :disc_super discr_closure
  :named_name '"DISCR_NORMALIZING_CLOSURE")

(defclass class_normal_magic_binding
  :doc #{The $CLASS_NORMAL_MAGIC_BINDING is tricky, rarely
  used (e.g. for @code{code_chunk} tags): the $NMAGIC_VALUE is the
  returned value of its $BINDER. If it is a closure of
  DICR_NORMALIZING_CLOSURE, that closure is applied to normalize.}#
  :super class_any_binding
  :fields (nmagic_value)
)

;; a simple stuff is a non-object, a symbol (or keyword or clonedsym),
;; ...
(defclass class_nrep_simple
  :doc #{The $CLASS_NREP_SIMPLE is for simple normal things -e.g. normal
  symbols.}#
  :super class_nrep
  :fields ( ))

;; a normalized expression should never be the result of normal_exp;
;; it should only appear in bindings!
(defclass class_nrep_expression
  :doc #{Common superclass $CLASS_NREP_EXPRESSION of normalized expressions
  which can only appear in normal bindings.}#
  :super class_nrep
  :fields ( ))

;; normalized typed expressions also have a ctype
(defclass class_nrep_typed_expression
  :doc #{Common super-class $CLASS_NREP_TYPED_EXPRESSION of typed normalized
  expressions. $NEXPR_CTYP gives its c-type.}#
  :super class_nrep_expression
  :fields (nexpr_ctyp                   ;the ctype
           ))

;; normalized typed expressions with arguments
(defclass class_nrep_typed_expression_with_arguments
  :doc #{Common super-class
$CLASS_NREP_TYPED_EXPRESSION_WITH_ARGUMENTS of typed normalized
expressions with normalized arguments. $NEXPR_ARGS is the tuple of
normalized arguments.}#
  :super class_nrep_typed_expression
  :fields (nexpr_args))

;; normal applications have simple functions & arguments
(defclass class_nrep_apply
  :super class_nrep_typed_expression_with_arguments
  :doc #{The $CLASS_NREP_APPLY class is for normal
applications. $NAPP_FUN is the simple function to apply to $NEXPR_ARGS.}#
  :fields (napp_fun                     ;simple function to apply
           ))

;; normal hook calls
(defclass class_nrep_hook_call
  :super class_nrep_typed_expression_with_arguments
  :doc #{The $CLASS_NREP_HOOK_CALL is for normal hook calls.
  $NHOOK_CALLED is the called hook. $NHOOK_OUTS it the actual output
  arguments to the hook. $NHOOK_DESCR is the descriptor.}#
  :fields (nhook_name
           nhook_called
           nhook_outs
           nhook_descr
           ))

;; normalized multiresult apply
(defclass class_nrep_multiapply
  :doc #{The $CLASS_NREP_MULTIAPPLY is for normal applications of
functions with several results within $MULTICALL. $NMULAPP_BINDINGS is
the tuple of formal result bindings. $NMULAPP_BODY is the normal
body.}#
  :super class_nrep_apply
  :fields (nmulapp_bindings             ;a tuple of formal result bindings
           nmulapp_body                 ;body normexp
           ))

;;; normal message sending
(defclass class_nrep_msend
  :doc #{The $CLASS_NREP_SEND is for normal message send (or message
passing), with a single result. $NSEND_SEL is the normalized selector,
$NSEND_RECV the normalized receiver, with $NEXPR_ARGS giving the
normalized arguments.}#
  :super class_nrep_typed_expression_with_arguments
  :fields (nsend_sel               ;the normalized selector occurrence
           nsend_recv              ;the receiver
           ))



;; normalized multiresult message send
(defclass class_nrep_multimsend
  :doc #{The $CLASS_NREP_MULTIMSEND is for normal message sends with
multiple results thru $MULTICALL. $NMULSEND_BINDINGS is the tuple of
formal result bindings, and $NMULSEND_BODY is the normalized body.}#
  :super class_nrep_msend
  :fields (nmulsend_bindings            ;tuple of formal bindings
           nmulsend_body                ;body normexp
           ))

;; normal chunk is a normalized expansion of primitive
(defclass class_nrep_chunk
  :doc #{The $CLASS_NREP_CHUNK is for normalized expansion of
primitive or cmatcher expressions. Field $NCHUNK_EXPANSION is the
expansion - where strings of $DISCR_VERBATIM_STRING are handled
specifically. Field $NCHUNK_OPER is the operator.}#
  :super class_nrep_typed_expression
  :fields (nchunk_expansion             ;the expansion
           nchunk_oper                  ;the operator (primitive or cmatcher)
           ))

;; normal comment is a normalized comment
(defclass class_nrep_comment
  :doc #{The $CLASS_NREP_COMMENT if for normalized comments in the
generated C code. The field $NCOMM_STRING gives the comment.}#
  :super class_nrep_expression
  :fields (ncomm_string ;the comment
           ))

;; normal lets have simple binding & body subexpressions
(defclass class_nrep_let
  :doc #{The $CLASS_NREP_LET is for normalized lets. The
$NLET_BINDINGS field is a tuple of $CLASS_NORMAL_LET_BINDING
instances. The $NLET_BODY field is the normal body. The normalization
process introduce many such normal lets.}#
  :super class_nrep_expression
  :fields (nlet_bindings                ;a tuple of class_normal_let_binding-s
           nlet_body
           ))

;; normal letrec 
(defclass class_nrep_letrec
  :doc #{The $CLASS_NREP_LETREC is for normalized letrec. The field
$NLETREC_FILL_BINDINGS is the list of internal normal bindings to fill
the letrec-ed constructions. The field $NLETREC_BODY_BINDINGS is the
tuple of internal normal bindings for the body.  The field
$NLETREC_LOCSYMS is the tuple of local symbol occurrences.}#
  :super class_nrep_let
  :fields (
           ;; the nlet_bindings is a tuple of constructive bindings
           nletrec_fill_bindings 
           nletrec_body_bindings 
           nletrec_locsyms
))

;; normal return have a main & supplementary subexpressions
(defclass class_nrep_return
  :doc #{The $CLASS_NREP_RETURN is for normalized returns. The primary
returned value is given thru $NRET_MAIN field. The secondary
returned things are thru $NRET_REST tuple.}#
  :super class_nrep_expression
  :fields (nret_main                    ;main normal expression to return
           nret_rest                    ;tuple of normal expr...
           ))

;; common normal for if, ifisa ...
(defclass class_nrep_ifcommon
  :doc #{The $CLASS_NREP_IFCOMMON is the common superclass for
normalized if-like tests. $NIF_THEN gives the then branch, and
$NIF_ELSE gives the else branch.}#
  :super class_nrep_typed_expression
  :fields (nif_then
           nif_else
           ))

;;; common normal for testing some value
(defclass class_nrep_iftestvalue
  :doc #{The $CLASS_NREP_IFTESTVALUE is a common superclass for
  testing about some given value $NIF_TESTVAL}# 
  :super class_nrep_ifcommon
  :fields (nif_testval
))

;; normal if is_a(value,class) then else
(defclass class_nrep_ifisa
  :doc #{The $CLASS_NREP_IFISA is for normalized $IS_A
  tests. Inherited $NIF_TESTVAL gives the value to be tested, and
  $NIFA_CLASS gives the normalized class data in which the value is
  tested for membership.}#
  :super class_nrep_iftestvalue
  :fields (nifa_class                   ;normal class 
))

(defclass class_nrep_iftuplesized
  :doc #{The $CLASS_NREP_IFTUPLESIZED is for normalized tests of
  multiple of given size. Inherited $NIF_TESTVAL gives the value to be tested (if
  it is multiple), and $NIF_TUPSIZ gives the size to be tested (if it
  has that size).}#
  :super class_nrep_iftestvalue
  :fields (nif_tupsiz))

;; normal if_variadic(variadic,typetuple) then ..
(defclass class_nrep_ifvariadic
  :doc #{The $CLASS_NREP_IFVARIADIC is for normalized $VARIADIC
  tests. $NIFV_VARIADIC gives the variadic name, and $NIFV_CTYPES
  gives the tuple of ctypes.}#
  :super class_nrep_ifcommon
  :fields (nifv_variadic
           nifv_ctypes))

;; normal consume_variadic 
(defclass class_nrep_consume_variadic
  :super class_nrep_expression
  :doc #{The $CLASS_NREP_CONSUME_VARIADIC is for $VARIADIC argument
consumption.  Field $NCONSVA_VARIADIC gives the variadic, and
$NCONSVA_CTYPES the consumed types of arguments.  }#
  :fields (
           nconsva_variadic
           nconsva_ctypes
))

;; normal if same (t1,t2) then else
(defclass class_nrep_ifsame
  :doc #{The $CLASS_NREP_IFSAME is for normalized identity tests for matching. $NIFS_LEFT and $NIFS_RIGHT are the simple stuff to compare for identity.}#
  :super class_nrep_ifcommon
  :fields (nifs_left 
           nifs_right))

;; normal if have simple test, then, else clauses & a ctype
(defclass class_nrep_if
  :doc #{The $CLASS_NREP_IF is for usual normalized if-test. $NIF_TEST
gives the tested thing.}#
  :super class_nrep_ifcommon
  :fields (nif_test
           ))

;; normal ifcpp have a symbol and a ctyp. Perhaps it should be
;; refactored using class_nrep_ifcommon?
(defclass class_nrep_cppif
  :doc #{The $CLASS_NREP_CPPIF is for cppif compile-time
tests. $NIFP_COND is the tested cpp symbol. $NIFP_THEN the then
part, $NIFP_ELSE the else part, $NIFP_CTYP the ctype.}#
  :super class_nrep_expression
  :fields (nifp_cond
           nifp_then
           nifp_else
           nifp_ctyp
           ))

;; normal progn has a distingished last
(defclass class_nrep_progn
  :doc #{The $CLASS_NREP_PROGN is for normalized $PROGN sequences. The
  $NPROGN_SEQ field is the tuple of all-but-last subexpressions, and
  the last one is given in $NPROGN_LAST.}#
  :super class_nrep_expression
  :fields (nprogn_seq                   ;tuple of all but last
           nprogn_last
           ))

(defclass class_nrep_checksignal
  :doc #{The $CLASS_NREP_CHECKSIGNAL is an internal expression to check interrupts, 
  corresponding to emission of the melt_check_interrupt() C macro. 
  It is emitted at safe places.}#
  :super class_nrep_expression
  :fields ()
)

(defclass class_nrep_putmodulevar
  :super class_nrep_expression
  :fields (nputmod_destvar
          nputmod_value))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(compile_warning ":doc missing below")
;; normalized unsafe get field
(defclass class_nrep_unsafe_get_field
  :super class_nrep_expression
  :fields (nuget_obj
           nuget_field))




;; normalized unsafe_put_field
(defclass class_nrep_unsafe_put_fields
  :super class_nrep_expression
  :fields (nuput_obj
           nuput_fields))

;; normalized unsafe nth_component
(defclass class_nrep_unsafe_nth_component
  :super class_nrep_expression
  :fields (nunth_tuple
           nunth_index))

;; normalized setq
(defclass class_nrep_setq
  :super class_nrep_expression
  :fields (nstq_var
           nstq_exp
           ))

;; normalized forever
(defclass class_nrep_forever
  :super class_nrep_expression
  :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_expression
  :fields (nexit_bind                   ;the label binding
           nexit_val                    ;the exited value
           ))

;; normalized again
(defclass class_nrep_again
  :super class_nrep_expression
  :fields (nagain_bind                  ;the label binding
           ))

;; 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_instance
  :super class_nrep_expression
  :fields (nmins_class                  ;the instanciated class
           nmins_cladata                ;its data
           nmins_fields                 ;the tuple of field assignments
           ))

;; normalized variadic argument retrieval
(defclass class_nrep_variadic_argument
  :super class_nrep_expression
  :fields (nvarg_variadic ;variadic symbol for index
           nvarg_ctyp     ;ctype of argument
           nvarg_offset   ;boxed integer offset
           ))

;; normalized lambda
(defclass class_nrep_lambda 
  :super class_nrep_expression
  :fields (nlambda_proc                 ;the procedure
           nlambda_constrout            ;the constant routine
           nlambda_closedv              ;the tuple of closed normal values
           ))

;; normalized lambda for :macro binding
(defclass class_nrep_macrolambda
  :super class_nrep_lambda
  :fields ()
)

;; normalized citeration
(defclass class_nrep_citeration
  :super class_nrep_expression
  :fields (nciter_citerator             ;the citerator
           nciter_chunkbefore           ;the expansed chunk before
           nciter_chunkafter            ;the expansed chunk after
           nciter_body                  ;the normalized body
           nciter_statocc               ;the state local occurrence
           nciter_locbindings           ;the local bindings
           nciter_bodbindings           ;normalized body bindings
           ))

;; normalized tests sequence, used for matches
(defclass class_nrep_tests
  :super class_nrep_expression
  :fields (ntests_testseq               ;the tuples of normal tests
           ;;;; see file warmelt-normatch.melt
))

;;;;;;;;;;;;;;;;
(defclass class_normal_constructor_binding
  :doc #{The internal $CLASS_NORMAL_CONSTRUCTOR_BINDING is the common
super-class of constructor bindings in LETREC... Field $NCONSB_LOC
gives the optional location, field $NCONSB_DISCR gives the normalized
discriminant, and field $NCONSB_NLETREC gives the normal letrec containing it..}#
  :super class_any_binding
  :fields (nconsb_loc nconsb_discr nconsb_nletrec)
)

(defclass class_normal_constructed_tuple_binding
  :doc #{The internal $CLASS_NORMAL_CONSTRUCTED_TUPLE_BINDING is the
class of tuple constructor bindings. Field $NTUPB_COMP gives the tuple
of initial normalized components.}#
  :super class_normal_constructor_binding
  :fields (ntupb_comp))

(defclass class_normal_constructed_pair_binding
  :doc #{The internal $CLASS_NORMAL_CONSTRUCTED_PAIR_BINDING is the
  class of pair constructor bindings. Field $NPAIRB_HEAD gives the
  normalized head, and $NPAIRB_TAIL gives the normalized tail.}#
  :super class_normal_constructor_binding
  :fields (npairb_head npairb_tail))

(defclass class_normal_constructed_list_binding
  :doc #{The internal $CLASS_NORMAL_CONSTRUCTED_LIST_BINDING is the
class of list constructor bindings. Field $NLISTB_FIRST gives the
initial normalized first pair, and field $NLISTB_LAST gives the last
one. Field $NLISTB_PAIRSB gives the tuple of constructed pair bindings}#
  :super  class_normal_constructor_binding
  :fields (nlistb_first nlistb_last nlistb_pairsb))

(defclass class_normal_constructed_lambda_binding
  :doc #{The internal $CLASS_NORMAL_CONSTRUCTED_LAMBDA_BINDING is the
class of lambda constructor bindings. Field $NLAMBDAB_NCLOSED gives
the normalized closed values, and $NLAMBDAB_DATAROUT gives the normalized routine data, and $NLAMBDAB_CONSTROUT its constant.}#
  :super  class_normal_constructor_binding
  :fields (nlambdab_nclosed nlambdab_constrout nlambdab_datarout))

(defclass class_normal_constructed_instance_binding
  :doc #{The internal $CLASS_NORMAL_CONSTRUCTED_INSTANCE_BINDING is
the class of instance constructor bindings. Field $NINSTB_SLOTS is the
tuple of the normalized slots, and $NINSTB_CLABIND is the class binding.}#
  :super  class_normal_constructor_binding
  :fields (ninstb_slots ninstb_clabind))

(defclass class_normal_module_variable_binding
  :doc #{The internal $CLASS_NORMAL_MODULE_VARIABLE_BINDING is the
class of module variable bindings. }#
  :super class_variable_binding
  :fields (nvarb_num))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; procedures
(defclass class_nrep_anyproc
  :doc #{The $CLASS_NREP_ANYPROC is the common super-class for
procedures. Field $NPROC_BODY is the normalized body.}#
  :super class_nrep
  :fields (
           nproc_body
           ))


;; the class of the initial procedure
(defclass class_nrep_initproc
  :super class_nrep_anyproc
  :doc #{The $CLASS_NREP_INITPROC is the class for the initial
procedure in a module. Field $NINIT_TOPL is the list of top-level
normalized expressions. Field $NINIT_DEFBINDS is the list of $DEFINE-d
bindings. Field $NINIT_IMPORTS is the list of imports.}#
  :fields (ninit_topl                   ;list of toplevel nrep
           ninit_defbinds               ;list of define-d bindings
           ninit_imports                ;list of imports
           ninit_importexprs            ;tuple of import assignments
           ))

;; the class of the initial procedure when extending a module
(defclass class_nrep_initextendproc
  :super class_nrep_initproc
  :doc #{The $CLASS_NREP_INITEXTENDPROC is the class for the initial
extending procedure for an existing module. Field ninitextend_modenv
is the extended environment.}#
  :fields (ninitextend_modenv
           ))


(defclass class_nrep_closproc
  :super class_nrep_anyproc
  :doc #{The internal $CLASS_NREP_CLOSPROC is the super-class for
  closing procedures with optional name $NRCLOP_NAME, [input]
  arguments bindings tuplz $NRCLOP_ARGBINDTUPLE, closed bindings list
  $NRCLOP_CLOBINDLIST, constant list $NRCLOP_CONSTLIST, and object
  const cache map $NRCLOP_OBJCONSTCACHEMAP}#
  :fields (nrclop_name
           nrclop_argbindtuple
           nrclop_clobindlist
           nrclop_constlist
           nrclop_objconstcachemap
           ))



;; the class of the normalized hook procedure
(defclass class_nrep_hookproc
  :super class_nrep_closproc
  :doc #{The $CLASS_NREP_HOOKPROC is the class for a hook
procedure in a module, defined with $DEFHOOK. }#
  :fields (nrhook_outb                  ;output arguments binding tuple
           nrhook_ctype                 ;ctype of result
           nrhook_datahook              ;hook data object
           ))

;; normal routine procedure
(defclass class_nrep_routproc
  :super class_nrep_closproc
  :doc #{The $CLASS_NREP_ROUTPROC is the class for normal routine
procedures, representing $DEFUN or $LAMBDA code. Field $NRPRO_DATAROUT
is the routine data object. Field $NRPRO_DATACLOS is the closure data
object. Field $NRPRO_THUNKLIST is the list of thunks to be called when
compiling it. Field $NRPRO_VARIADIC is non-null if the routine is
variadic.}#
  :fields (
           nrpro_datarout               ;routine data object
           nrpro_dataclos               ;closure data object
           nrpro_thunklist              ;list of thunks to be called when compiling it
           nrpro_variadic               ;non null iff variadic
           ))

(defclass class_nrep_lambdaroutproc
  :super class_nrep_routproc
  :doc #{The $CLASS_NREP_LAMBDAROUTPROC is the class for $LAMBDA
related routine procedures.}#
  :fields ())

(defclass class_nrep_macrolambdaroutproc
  :super class_nrep_routproc
  :doc #{The $CLASS_NREP_LAMBDAROUTPROC is the class for :macro lambda
related routine procedures.}#
  :fields ())

(defclass class_nrep_defunroutproc
  :super class_nrep_routproc
  :doc #{The $CLASS_NREP_DEFUNROUTPROC is the class for $DEFUN related
routine procedures.}#
  :fields ())




;;; static normalized predef
(defclass class_nrep_predef
  :doc #{The $CLASS_NREP_PREDEF is for normalized predefined
  values. $NRPREDEF gives the symbolic or integer number.}#
  :super class_nrep_simple
  :fields (
           nrpredef                     ;the predef is a symbol or a boxed integer
           ))

;; normalized nil
(defclass class_nrep_nil
  :doc #{The $CLASS_NREP_NIL is for normalized nil occurrences.}#
  :super class_nrep_simple
  :fields (
           ))


;; give the normal import of some imported value or literal named value
(defun normal_import (nimpval env ncx psloc)
  (debug "normal_import nimpval=" nimpval "\n.. ncx=" ncx)
  (let ( (nsymb ())
         (nsymbname ())
         )
    (cond ( (is_a nimpval class_nrep_importedval)
            (setq nsymb (get_field :nimport_symb  nimpval))
            (setq nsymbname (get_field :named_name nsymb))
            (debug "normal_import importedval nsymb=" nsymb "\n.. nsymbname=" nsymbname)
            )
          ( (is_a nimpval class_nrep_literalvalue)
            (setq nsymb (get_field :nlitval_symbol nimpval))
            (setq nsymbname (get_field :named_name nsymb))
            (debug "normal_import literalvalue nsymb=" nsymb "\n.. nsymbname=" nsymbname)
            )
          (:else
           (debug "normal_import bad nimpval=" nimpval)
           (assert_msg "normal_import with unepxected nimpval" () nimpval)
           (return)
           )
          )
    (assert_msg "check nsymb" (is_a nsymb class_symbol) nsymb)
    (let (
          (modctx (get_field :nctx_modulcontext ncx))
          (curproc (get_field :nctx_curproc ncx))
          (ndataparenv (get_field :nctx_qdatparmodenv ncx))
          (modname (get_field :mocx_modulename modctx))
          (sloc (or (get_field :nrep_loc nimpval) psloc))
          (nimphc
           (instance class_nrep_hook_call
                     :nrep_loc sloc
                     :nexpr_ctyp ctype_value
                     :nhook_name '"HOOK_SYMBOL_IMPORTER"
                     :nexpr_args (tuple nsymbname modname ndataparenv)
                     :nhook_called (normal_predef hook_symbol_importer ncx
                                                  sloc "hook_symbol_importer")
                      
                     :nhook_outs (tuple)
                     :nhook_descr (hook_data hook_symbol_importer)
                     )
           )
          (nsetimp (instance class_nrep_setq
                             :nrep_loc sloc
                             :nstq_var nimpval
                             :nstq_exp nimphc
                             ))
          )
      (debug "normal_import nimphc=" nimphc "\n.. nimpval=" nimpval "\n.. nsetimp=" nsetimp)
      (return nsetimp)
      )))

;;; quasidata are stuff to be computed inside the initial routine;
;;; most of them are plain data, but current_module_environment_reference &
;;; parent_module_environment need specific stuff

(defclass class_nrep_quasidata
  :doc #{The $CLASS_NREP_QUASIDATA is an abstract super-class for data
  computed during initialization.}#
  :super class_nrep
  :fields (
           ))

(defclass class_nrep_bound_data
  :super class_nrep_quasidata
  :doc #{The internal $CLASS_NREP_BOUND_DATA is for normalized defined and
  bound data. The objnum of its instance is the predefined rank if
  any.}#
  ;; the objnum is the predefined rank if any
  :fields  (ndata_name                ;name if any of the data
            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
            )
  )

(defclass class_nrep_discriminated_data
  :doc #{The internal $CLASS_NREP_DISCRIMINATED_DATA is for defined
  data with a static disciminant.}#
  :super class_nrep_bound_data
  :fields (
           ndata_discrx               ;discriminant normal expression 
           ))

;; normal "static" instance - built at modules initialization
(defclass class_nrep_datainstance
  :super class_nrep_discriminated_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_discriminated_data
  :fields ( nstr_string                 ;the string
            ))

;; normal "static" boxed integer
(defclass class_nrep_databoxedinteger
  :super class_nrep_discriminated_data
  :fields ( nboxint_num                 ;the numerical integer
            ))

;; normal "static" tuple
(defclass class_nrep_datatuple
  :super class_nrep_discriminated_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_discriminated_data
  :fields (ndrou_proc                   ;associated procedure
           ))

;; normal static hook data
(defclass class_nrep_datahook
  :super class_nrep_discriminated_data
  :fields (ndhook_proc             ;associated procedure
           ndhook_data             ;the data
           ndhook_closv            ;tuple of closed values
           ndhook_predef           ;the predefined, if any
           ndhook_modvarbind       ;the module variable binding if any
           ))

;; normal static closure data
(defclass class_nrep_dataclosure
  :super class_nrep_discriminated_data
  :fields (ndclo_proc                   ;associated procedure
           ndclo_closv                  ;tuple of closed values
           ))

;; normal static start value
;; obtained from an initial binding, imported from parent environment
(defclass class_nrep_importedval
  :super class_nrep_simple
  :fields (nimport_symb                 ;the symbol
           nimport_sydata               ;the symbol data
           ))

;; normal literal value
(defclass class_nrep_literalvalue
  :super class_nrep_simple
  :fields (nlitval_regval
           ))

;; normal literal named values
(defclass class_nrep_literalnamedvalue
  :super class_nrep_literalvalue
  :fields (nlitval_symbol
           ))

;; normal static variable occurrence
(defclass class_nrep_modulevarocc
  :super class_nrep_simple
  :fields (nmodvar_bind ;the normal variable binding, containing the index
           ))

;; normal  occurrence of a symbol 
(defclass class_nrep_symocc
  :super class_nrep_simple
  :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 quasi constants for current_module_environment_reference &
;;; parent_module_environment & constants
(defclass class_nrep_quasiconstant
  :super class_nrep_simple
  :fields (nconst_sval        ;source value
           nconst_proc        ;containing proc
           nconst_data        ;normalized data or stuff inside iniproc
           ))

;; normal constant (.e.g a quoted symbol, a keyword, a define-d value ...)
(defclass class_nrep_constant
  :super class_nrep_quasiconstant
  :fields (
           ))

(defclass class_nrep_defined_constant
  :super class_nrep_quasiconstant
  :fields (nconst_defbind
           )
  )

;; noormal current_module_environment_reference quasiconst
(defclass class_nrep_quasiconst_current_module_environment_reference
  :super class_nrep_quasiconstant
  :fields ( nqcmec_comment
            ))


;; normal current_module_environment_reference quasidata
(defclass class_nrep_quasidata_current_module_environment_reference
  :super class_nrep_quasidata
  :fields (
           ))

;; noormal parent_module_environment quasiconst
(defclass class_nrep_quasiconst_parent_module_environment
  :super class_nrep_quasiconstant
  :fields (
           ))

;; normal parent_module_environment quasidata
(defclass class_nrep_quasidata_parent_module_environment
  :super class_nrep_quasidata
  :fields (
           ))

;; data field accessor (mostly used for defclass initialization) this
;; translates into melt_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_expression
  :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 melt_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_expression
  :fields (naccm_mul           ;data for the multiple to be accessed
           naccm_ix            ;index to be accessed (a boxed integer)
           ))

;; normalized store predefined
(defclass class_nrep_store_predefined
  :super class_nrep_expression
  :fields (nstpd_predef
           nstpd_value
           ))

;; normalized update current module environment box
(defclass class_nrep_update_current_module_environment_reference
  :super class_nrep_expression
  :fields (
           nucmeb_expr          ;the normalized expression
                                        ;computing the box
           ncumeb_comment               ;optional comment
           ))

;; normalized check of current running module environment box
(defclass class_nrep_check_running_module_environment_container
  :super class_nrep_expression
  :fields (nchrumod_comment             ;optional comment
           ))

;;; export all the normalized representations classes
(export_class ;; normal representations classes in alphabetical order

 class_normal_constructed_instance_binding
 class_normal_constructed_lambda_binding
 class_normal_constructed_list_binding
 class_normal_constructed_pair_binding
 class_normal_constructed_tuple_binding
 class_normal_constructor_binding
 class_normal_magic_binding
 class_normal_module_variable_binding
 class_nrep
 class_nrep_again
 class_nrep_anyproc
 class_nrep_apply
 class_nrep_bound_data
 class_nrep_check_running_module_environment_container
 class_nrep_checksignal
 class_nrep_chunk
 class_nrep_citeration
 class_nrep_closedocc
 class_nrep_closproc
 class_nrep_comment 
 class_nrep_constant
 class_nrep_constocc
 class_nrep_consume_variadic
 class_nrep_cppif
 class_nrep_databoxedinteger
 class_nrep_dataclosure
 class_nrep_datahook
 class_nrep_datainstance
 class_nrep_datakeyword
 class_nrep_dataroutine
 class_nrep_datastring
 class_nrep_datasymbol
 class_nrep_datatuple
 class_nrep_defined_constant
 class_nrep_defunroutproc
 class_nrep_discriminated_data
 class_nrep_exit
 class_nrep_expression
 class_nrep_fieldacc
 class_nrep_fieldassign
 class_nrep_forever
 class_nrep_hookproc
 class_nrep_hook_call
 class_nrep_if
 class_nrep_ifcommon
 class_nrep_ifisa
 class_nrep_ifsame
 class_nrep_iftestvalue
 class_nrep_iftuplesized
 class_nrep_ifvariadic
 class_nrep_importedval
 class_nrep_initextendproc
 class_nrep_initproc
 class_nrep_instance
 class_nrep_lambda
 class_nrep_lambdaroutproc
 class_nrep_let
 class_nrep_letrec
 class_nrep_literalnamedvalue
 class_nrep_literalvalue
 class_nrep_locsymocc
 class_nrep_macrolambda
 class_nrep_macrolambdaroutproc
 class_nrep_msend
 class_nrep_multacc
 class_nrep_multiapply
 class_nrep_multimsend
 class_nrep_nil
 class_nrep_predef
 class_nrep_progn
 class_nrep_putmodulevar
 class_nrep_quasiconst_current_module_environment_reference
 class_nrep_quasiconst_parent_module_environment
 class_nrep_quasiconstant
 class_nrep_quasidata
 class_nrep_quasidata_current_module_environment_reference
 class_nrep_quasidata_parent_module_environment
 class_nrep_return
 class_nrep_routproc
 class_nrep_setq
 class_nrep_simple
 class_nrep_modulevarocc
 class_nrep_store_predefined
 class_nrep_symocc
 class_nrep_typed_expression
 class_nrep_typed_expression_with_arguments
 class_nrep_unsafe_get_field
 class_nrep_unsafe_nth_component
 class_nrep_unsafe_put_fields
 class_nrep_update_current_module_environment_reference
 class_nrep_variadic_argument
 )                                      ;end of export normal classes



;;;;;;; primitive for extra warnings
(defprimitive has_extra_warnings () :long "(extra_warnings)")



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

;;; add some data to a normalization context and return it
(defun add_nctx_data (nctx ndata)
  (debug "add_nctx_data nctx=" nctx)
  (debug "add_nctx_data ndata=" ndata "\n")
  (shortbacktrace_dbg "add_nctx_data" 16)
  (assert_msg "check nctx" (is_a nctx class_normalization_context) nctx)
  (assert_msg "check ndata" (is_a ndata class_nrep_bound_data) ndata)
  (assert_msg "fresh ndata" (null (unsafe_get_field :ndata_rank ndata)) ndata)
  (let ( (datlis (unsafe_get_field :nctx_datalist nctx)) 
         (ncurproc (unsafe_get_field :nctx_curproc nctx))
         )
    (debug "add_nctx_data ncurproc=" ncurproc)
    (debug "add_nctx_data datlis=" datlis)
    (assert_msg "check datlis" (is_list datlis) datlis)
    (let ( (lastdat (pair_head (list_last datlis)))  )
      (if (is_a lastdat class_nrep_bound_data)
          (let ( (:long lastrk (get_int (unsafe_get_field :ndata_rank lastdat))) )
            (assert_msg "check lastrk" (>i lastrk 0) lastrk)
            (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 "add_nctx_data updated datlis=" datlis "\n result ndata=" ndata)
    ndata
    ))

  ;; the automatically generated _warmelt-predef.melt file defines a
  ;; fill_initial_predefmap function
(load "_warmelt-predef.melt")

  ;; internal primitive to return the last predefined index
(defprimitive last_globpredef_index () :long
  "BGLOB__LASTGLOB")



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass class_literal_value 
  :super class_proped
  :fields (litv_value
           litv_rank
           litv_loc)
  :doc #{$CLASS_LITERAL_VALUE is the class managing literal values in runtime extension modules.
  $LITV_VALUE is the literal value itself
  $LITV_RANK is its unique rank in the extension module
  $LITV_LOC may contain its stack location}#
  )
(export_class class_literal_value)

(defun register_literal_value (val modctx)
  (debug "register_literal_value val=" val "\n in modctx=" modctx)
  (assert_msg "check modctx" (is_a modctx class_running_extension_module_context) modctx)
  (let ( (litvalist (get_field :morcx_litervalist modctx))
         (litobjmap (get_field :morcx_literobjmap modctx))
         (countlit (get_field :morcx_countlitval modctx))
         (:long count (get_int countlit))
         )
    (assert_msg "check litvalist" (is_list litvalist) litvalist)
    (assert_msg "check litobjmap" (is_mapobject litobjmap) litobjmap)
    (assert_msg "check countlit" (is_integerbox countlit) countlit)
    ;; check once in a while that the counter is the list length
    (assert_msg "check count" (or (%iraw count 8) (==i count (list_length litvalist))) count)
    (cond ( (null val)
            (assert_msg "null literal value" ())
            (return))
          ( (is_integerbox val)
            (assert_msg "integer literal value" () val)
            (return))
          ( (is_string val)
            (assert_msg "string literal value" () val)
            (return))
          ( (is_object val)
            (let ( (litv (mapobject_get litobjmap val))
                   )
              (cond
               (litv 
                (debug "register_literal_value found litv=" litv)
                (assert_msg "check litv" (is_a litv class_literal_value) litv)
                (assert_msg "check old found value" (== (get_field :litv_value litv) val) litv val)
                )
               (:else
                (setq litv (instance class_literal_value
                                     :litv_value val
                                     :litv_rank (make_integerbox discr_constant_integer count)
                                     :litv_loc ()
                                     ))
                (list_append litvalist litv)
                (put_int countlit (+i count 1))
                (mapobject_put litobjmap val litv)
                (debug "register_literal_value new litv=" litv "\n updated litobjmap=" litobjmap)
                )
               )
              (return litv)
              ))
          (:else
           ;; non-object value
           (let ( (litv (instance class_literal_value
                                  :litv_value val
                                  :litv_rank (make_integerbox discr_constant_integer count)
                                  :litv_loc ()
                                  ))
                  )
             (list_append litvalist litv)
             (put_int countlit (+i count 1))
             (debug "register_literal_value nonobject value litv=" litv)
             (return litv)
             ))
          )))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; create a normalization context
(defun create_normcontext (modctx)
  :doc #{Internal routine to reate a normalization context for module
  context $MODCTX, used to compile modules.}#
  (debug "create_normcontext modctx=" modctx)
  (shortbacktrace_dbg "create_normcontext" 12)
  (let ( (:long maxpredefix (last_globpredef_index))
         (:long ix 1)
         (predefmap (make_mapobject discr_map_objects (+i 19 (*i 2 maxpredefix))))
         (valmap (make_mapobject discr_map_objects 350))
         )
    (assert_msg "check modctx" (is_a modctx class_any_module_context) modctx)
    (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)))
    (fill_initial_predefmap predefmap)
    (let ( (inipro  (instance class_nrep_initproc
                              :ninit_topl (make_list discr_list)
                              :ninit_defbinds (make_list discr_list)
                              :nrep_loc ()
                              )) 
           (ncx (instance class_normalization_context
                          :nctx_initproc inipro
                          :nctx_proclist (make_list discr_list)
                          :nctx_datalist (make_list discr_list)
                          :nctx_valuelist (make_list discr_list)
                          :nctx_symbmap  (make_mapstring discr_map_strings 50)
                          :nctx_keywmap  (make_mapstring discr_map_strings 40)
                          :nctx_predefmap predefmap
                          :nctx_valmap valmap
                          :nctx_valbindmap (make_mapobject discr_map_objects 20)
                          ;; we need a symbcachemap for the toplevel expressions
                          :nctx_symbcachemap (make_mapobject discr_map_objects 30)
                          :nctx_curproc inipro
                          :nctx_modulcontext modctx
                          :nctx_qdatcurmodenvbox (instance class_nrep_quasidata_current_module_environment_reference
                                                           )
                          :nctx_qdatparmodenv (instance class_nrep_quasidata_parent_module_environment
                                                        )
                          :nctx_procurmodenvlist (make_list discr_list)
                          ))
           )
      (debug "create_normcontext make ncx=" ncx)
      (return ncx)
      )))



;;;;;;;;;;;;;;;;
(defun create_normal_extending_context (modctx modenv)
  :doc #{Internal routine to create a normalization context for module
  context $MODCTX, used to compile, e.g. for running, the extension of a module environment $MODENV.}#
  (debug "create_normal_extending_context start modctx=" modctx
         "\n* modenv=" modenv "\n")
  (shortbacktrace_dbg "create_normal_extending_context" 12)
  (let ( (:long maxpredefix (last_globpredef_index))
         (:long ix 1)
         (predefmap (make_mapobject discr_map_objects (+i 11 (*i 2 maxpredefix))))
         (valmap (make_mapobject discr_map_objects 91))
         )
    (assert_msg "check modctx" (is_a modctx class_running_extension_module_context) modctx)
    (assert_msg "check modenv" (is_a modenv class_environment) modenv)
    (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)))
    (fill_initial_predefmap predefmap)
    (let ( (inipro  (instance class_nrep_initextendproc
                              :ninit_topl (make_list discr_list)
                              :ninit_defbinds (make_list discr_list)
                              :nrep_loc ()
                              :ninitextend_modenv modenv
                              )) 
           (ncx (instance class_normalization_context
                          :nctx_initproc inipro
                          :nctx_proclist (make_list discr_list)
                          :nctx_datalist (make_list discr_list)
                          :nctx_valuelist (make_list discr_list)
                          :nctx_symbmap  (make_mapstring discr_map_strings 30)
                          :nctx_keywmap  (make_mapstring discr_map_strings 20)
                          :nctx_predefmap predefmap
                          :nctx_valmap valmap
                          :nctx_valbindmap (make_mapobject discr_map_objects 20)
                          ;; we need a symbcachemap for the toplevel expressions
                          :nctx_symbcachemap (make_mapobject discr_map_objects 10)
                          :nctx_curproc inipro
                          :nctx_modulcontext modctx
                          :nctx_qdatcurmodenvbox (instance class_nrep_quasidata_current_module_environment_reference
                                                           )
                          :nctx_qdatparmodenv (instance class_nrep_quasidata_parent_module_environment
                                                        )
                          :nctx_procurmodenvlist (make_list discr_list)
                          ))
           )
      (debug "create_normal_extending_context make inipro=" inipro "\n.. result ncx=" ncx "\n")
      (return ncx)
      )))


;;; the normal_exp selector 
;;;;; expected arguments: 
;;;   recv = the receiver, eg a sexpr
;;;   env = the environment 
;;;   ncx = the normalization context 
;;;   psloc = (parent) source location
;;;;; expected results: normalized + binding list 
;;; IMPORTANT NOTICE: even for simple expressions [like side-effecting
;;; expressions returning void, e.g. RETURN, EXIT, ... other simple
;;; side-effecting expressions like SETQ], the normalized should
;;; always be a simple occurrence, and the work being done in the
;;; bindings list.
(defselector normal_exp class_selector
  :doc #{Normalize an expression, often an S-expr or a literal
  constant. $RECV is the reciever, $ENV the environment of
  $CLASS_ENVIRONMENT, $NCX the normalization context of
  $CLASS_NORMALIZATION_CONTEXT and $PSLOC the parent source
  location. Should return a normalized thing, often an instance of
  $CLASS_NREP_LOCSYMOCC, and as a secondary result a list of
  bindings.)}#
  :formals (recv env ncx psloc)
                                        ;  :named_name (stringconst2val discr_namestring "NORMAL_EXP")
  )

;; many stuff, e.g. constant literal strings or numbers, are already normalized 
(defun normexp_identical (recv env ncx psloc)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  ;; is a no-op
  (debug "normexp_identical recv" recv)
  (return recv ()))

(install_method discr_string normal_exp  normexp_identical)
(install_method discr_integer normal_exp  normexp_identical)

(defun normexp_null (recv env ncx psloc)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check nctxt" (is_a ncx class_normalization_context) ncx)
  (let ( (normnull (instance class_nrep_nil :nrep_loc psloc)) )
    (debug "normexp_null normnull" normnull)
    (return normnull ())
    ))
(install_method discr_null_receiver normal_exp normexp_null)


;;; an object or a value may have to be normalized only when inside a
;;; constructed s-expression. The reader is not able to give such
;;; values.  So it practically happens only when running an
;;; evaluation.
;;;;;;;;;;;;;;;;
(defun normexp_any_object (recv env ncx psloc)
  (debug "normexp_any_object" " recv=" recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  ;; we should normalize arbitrary objects into themselves. However,
  ;; we should collect all these objects, so that the runtime
  ;; evaluator gets them all, so the normalized expression would be an
  ;; access to some constant offset inside a tuple
  (let ( (cla (discrim recv))
         (claname (get_field :named_name cla))
         (recname (get_field :named_name recv))
         )
    (if (is_string recname)
        (error_at psloc 
                  "unimplemented normalization for literal object named $1"_ recname))
    (error_at psloc 
                "unimplemented normalization for literal object of $1"_ claname)
    (assert_msg "@$@ unimplemented normexp_any_object" () recv)))
(install_method class_root normal_exp normexp_any_object)


(defun normexp_mixed_location (recv env ncx psloc)
  (debug "normexp_mixed_location" " recv=" recv)
  (let ( (filev ())
         (:long linenum 0)
         (:long colnum 0)
         )
    (code_chunk 
     normixloc_chk
     #{ /* normexp_mixed_location start $NORMIXLOC_CHK */
     source_location loc_$NORMIXLOC_CHK = melt_location_mixloc((melt_ptr_t)$RECV) ;
     $FILEV = meltgc_cached_string_path_of_source_location (loc_$NORMIXLOC_CHK) ;
     $LINENUM = LOCATION_LINE(loc_$NORMIXLOC_CHK)  ;
     $COLNUM = LOCATION_COLUMN(loc_$NORMIXLOC_CHK) ;
     /* normexp_mixed_location end $NORMIXLOC_CHK */}#)
    (debug "normexp_mixed_location" " filev=" filev "; linenum=" linenum "; colnum=" colnum)
    (let (
          (sloc (or psloc recv))
          (sdiscr (instance class_source_fetch_predefined
                            :loca_location sloc
                            :sfepd_predef 'discr_mixed_integer))
          (squofil (instance class_source_quote
                             :loca_location sloc
                             :squoted filev))
          (sprim (instance class_source_primitive
                            :loca_location sloc
                            :sprim_oper make_mixint
                            :sargop_args (tuple sdiscr squofil (constant_box linenum))))
           )
      (debug "normexp_mixed_location" " sprim=" sprim)
      (multicall
       (nres nbind)
       (normexp_primitive sprim env ncx psloc)
       (debug "normexp_mixed_location" " result nres=" nres "\n.. nbind=" nbind)
       (return nres nbind)
       )         
      )
    )
  )
(install_method discr_mixed_location normal_exp normexp_mixed_location)

(defun normexp_any_value (recv env ncx psloc)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  ;; we should normalize arbitrary values into themselves, unless when
  ;; they are containers for stuff like DISCR_TREE etc..., then we
  ;; should unbox that stuff.  so the normalized expression would be
  ;; an access to some constant offset inside a tuple or its unboxing
  (debug "normexp_any_value recv=" recv)
  (let ( (cla (discrim recv))
         (claname (get_field :named_name cla))
         )
    (error_at psloc 
              "unimplemented normalization for literal value of $1"_ claname)
    (warning_at psloc
                "unnormalizable literal value is $1" recv)
    (assert_msg "@$@ unimplemented normexp_any_value" () recv)))
(install_method discr_any_receiver normal_exp  normexp_any_value)

;;; catchall for src
(defun normexp_src_catchall (recv env ncx psloc)
  (debug "normexp_src_catchall recv=" recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (myclass (discrim recv))
         (myclassname (unsafe_get_field :named_name myclass)) )
    (error_at (unsafe_get_field :loca_location recv) 
                "unimplemented normalization for value of $1" myclassname)
    (assert_msg "normexp_src_catchall unimplemented normexp for src" () recv)
    ))
(install_method class_source normal_exp normexp_src_catchall)


;; normalization of lazy macro expansion
(defun normexp_lazymacroexp (recv env ncx psloc)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let (
        (sloc (get_field :loca_location recv))
        (lazymacfun (get_field :slazymacro_fun recv))
        (lazymacoper (get_field :slazymacro_oper recv))
        )
    (multicall 
     (mexp mresexp)
     (lazymacfun)
     (debug "normexp_lazymacroexp mexp" mexp)
     (if mresexp
         ;;; this happens in the pathological case when the lazy macro
         ;;; macro-expands to more than one result
         (error_at sloc "delayed lazy macro expansion cannot macro expand multiply"_))
     (if (is_a mexp class_source_lazy_macro_expansion)
         ;;; this happens in the pathological case when a macro
         ;;; operator is not defined
         (progn 
           (if (is_a lazymacoper class_symbol)
               (error_at sloc "undefined operator; unknown name $1"
                           (get_field :named_name lazymacoper))
             (error_at sloc "undefined macro; delayed lazy macro expansion too lazy"))
           (return)
           ))
     (multicall
      (nrep nbind)
      (normal_exp mexp env ncx psloc)
      (debug "normexp_lazymacroexp nrep=" nrep " nbind=" nbind)
      (return nrep nbind)
      )
     )))
(install_method class_source_lazy_macro_expansion normal_exp normexp_lazymacroexp)

;; 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
  )

;;; selector to compile a normalized stuff into an object
;;; receiver: the normalized stuff
;;; arguments: 
;;;; * GCX the code generation context
;;; result = the obj instruction or value

(defselector compile_obj class_selector
  )

;;; most stuff are really ctype_value
(defun gectyp_anyrecv (recv env) ctype_value)
(install_method discr_any_receiver 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 "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)
  (debug "normalize_tuple start tup=" tup " psloc=" psloc)
  (shortbacktrace_dbg "normalize_tuple" 16)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (if (null tup) 
      (return () ()))
  (assert_msg "check tup" (is_multiple tup) tup)
  (let ( (bindlist (make_list discr_list)) 
         (:long tuplen (multiple_length tup))
         (res (make_multiple discr_multiple tuplen))
         )
    (foreach_in_multiple
     (tup)
     (comp :long ix)
     (debug "normalize_tuple comp=" comp "\n ix=" ix)
     (multicall 
      (norcomp nbinds)
      (normal_exp comp env ncx psloc)
      (debug "normalize_tuple norcomp=" norcomp 
             "\n of discrim=" (discrim norcomp)
             "\n* nbinds=" nbinds 
             "\n* for comp=" comp 
             "\n ix=" ix)
      (assert_msg "check nbinds" (is_list_or_null nbinds) nbinds)
      ;; Shameful dirty hack for module variables; notably for
      ;; application, we need to put them into a local
      ;; binding, because meltgc_apply is passing argument
      ;; by references, and melt_module_var_fetch returns
      ;; a pointer value, not a reference. 
      (if (is_a norcomp class_nrep_modulevarocc)
          (let ( (nvarbind (unsafe_get_field :nmodvar_bind norcomp))
                 )
            (debug "normalize_tuple modulevarocc norcomp=" norcomp " ix#" ix)
            (if (null nbinds) 
                (setq nbinds (make_list discr_list)))
            (assert_msg "check nvarbind" (is_a nvarbind class_normal_module_variable_binding) nvarbind)
            (let ( (nvbinder (get_field :binder nvarbind))
                   (clonsym (clone_symbol nvbinder))
                   (clonbind (instance class_normal_let_binding
                                       :letbind_loc ()
                                       :binder clonsym
                                       :letbind_type ctype_value
                                       :letbind_expr norcomp))
                   (clonocc (instance class_nrep_locsymocc
                                      :nrep_loc ()
                                      :nocc_ctyp ctype_value
                                      :nocc_symb clonsym
                                      :nocc_bind clonbind))
                   )
              (when (!= (get_ctype norcomp env) ctype_value)
                  (error_at psloc "incompatible type of module variable $1 - needs a value" nvbinder))
              (list_append nbinds clonbind)
              (setq norcomp clonocc)
              )))
      ;;
      (assert_msg "check norcomp not class_nrep_expression" 
                  (is_not_a norcomp class_nrep_expression) norcomp)
      (if (is_list nbinds)
          (foreach_pair_component_in_list 
           (nbinds)
           (curpair bnd)
           (assert_msg "check bnd" (is_a bnd class_any_binding) bnd)
           (assert_msg "check bindlist" (is_list bindlist) bindlist)
           (list_append bindlist bnd)
           )
        )
      (debug "normalize_tuple ix#" ix " norcomp=" norcomp)
      (multiple_put_nth res ix norcomp)
      ))
    (if (not (is_pair (list_first bindlist)))
        (setq bindlist ()))
    (debug "normalize_tuple final res=" res "\n.. bindlist=" bindlist)
    (return res bindlist)
    ))


;; wrap a normal let around a single normalized expression & a bindinglist
(defun wrap_normal_let1 (nexp bindlist loc)
  (debug "wrap_normal_let1 nexp=" nexp " bindlist=" bindlist)
  (assert_msg "check bindlist" (is_list_or_null bindlist) bindlist)
  (list_every
   bindlist 
   (lambda (cbind) 
     (if (not (is_a cbind class_normal_let_binding))
           (debug "wrap_normal_let1 nexp=" nexp
                  " bindlist=" bindlist
                  " cbind" cbind))
     (assert_msg "check cbind wrapnormlet1" (is_a cbind class_normal_let_binding) cbind)))
  (if 
      (and (is_list bindlist)
           (is_pair (list_first bindlist)))
      (let ( (wnlet 
              (instance class_nrep_let
                        :nrep_loc loc
                        :nlet_bindings (list_to_multiple bindlist)
                        :nlet_body (tuple nexp)))
             )
        wnlet)
    nexp
    ))

;; wrap a normal let around a tuple of normalized expressions and a bindinglist
;; add an interrupt check
(defun wrap_normal_letseq (tupnexp bindlist loc)
  (debug "wrap_normal_letseq tupnexp=" tupnexp " bindlist=" bindlist " loc=" loc)
  (shortbacktrace_dbg "wrap_normal_letseq" 10)
  (assert_msg "check tupnexp" (is_multiple_or_null tupnexp) tupnexp)
  (assert_msg "check bindlist" (is_list_or_null bindlist) bindlist)
  (let ( (:long nbnexp (multiple_length tupnexp))
         )
    (cond
     ( (not (is_multiple tupnexp))
       (let ( (wnletn (wrap_normal_let1 tupnexp bindlist loc))
              )
       (debug "wrap_normal_letseq non-tuple tupnexp=" tupnexp 
              "\n return wnletn=" wnletn)
       (return wnletn)))
     ( (==i nbnexp 0)
       (assert_msg "check impossible nbnexp" () tupnexp))
     ( (==i nbnexp 1)
       (let ( (subnexp (multiple_nth tupnexp 0))
              (wnlet1 (wrap_normal_let1 subnexp bindlist loc))
              )
         ;; single subexpression
         (debug "wrap_normal_letseq return wnlet1=" wnlet1)
         (return wnlet1)
         ))
     ( :else                            ;more than one sub-expression
       (let (
             (ncheckint (instance class_nrep_checksignal
                                  :nrep_loc loc))
             (growntup (make_multiple discr_multiple (+i nbnexp 1)))
             )
         (multiple_put_nth growntup 0 ncheckint)
         (foreach_in_multiple 
          (tupnexp)
          (curnexp :long nix)
          (assert_msg "check curnexp" (or (is_not_object curnexp) (is_a curnexp class_nrep)) curnexp)
          (multiple_put_nth growntup (+i nix 1) curnexp))
         (list_every
          bindlist 
          (lambda (cbind) 
            (if (not (is_a cbind class_normal_let_binding))
                (debug "wrap_normal_letseq tuplexp=" tupnexp
                       " bindlist=" bindlist
                       " cbind=" cbind))
            (assert_msg "check cbind wrapnormletseq" 
                        (is_a cbind class_normal_let_binding) cbind)))
         (let ( (wnlet
                 (instance class_nrep_let
                           :nrep_loc loc
                           :nlet_bindings (list_to_multiple bindlist)
                           :nlet_body growntup))
                )
           (debug "wrap_normal_letseq return wnlet=" wnlet)
           (return wnlet)))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; utility to check that every normalized argument has a passable ctype
(defun check_ctype_nargs (nargs env sloc)
  (foreach_in_multiple 
   (nargs)
   (cnarg :long ix) 
   (let ( (ctyp (get_ctype cnarg env))
          (ctypname (get_field :named_name ctyp))
          )
     (assert_msg "check_ctype_nargs ctyp" (is_a ctyp class_ctype) ctyp)
     (when (not (is_string (unsafe_get_field :ctype_parstring ctyp)))
       (debug "check_ctype_nargs" " ix#" ix " cnarg=" cnarg
              "\n.. ctyp=" ctyp)
       (cond
        ( (is_a cnarg class_nrep_locsymocc)
          (error_at sloc "symbol $1 occurrence argument #$2 has invalid type $3"
                    (get_field :nocc_symb cnarg)
                    ix
                    ctypname))
        ( (or (is_string cnarg) (is_integerbox cnarg))
          (error_at sloc "literal $1 argument #$2 has invalid type $3"
                    cnarg ix ctypname)
          )
        (:else
         (error_at sloc "argument #$1 has invalid type $2"_ ix ctypname)
         )))
     )))


(defselector normalize_binding class_selector
  :doc #{Normalize a locally bound symbol. $RECV is the binding, $ENV
is the environment, $NCX is the normal context, $PSLOC the parent
source location.}#
  :formals (recv env ncx procs psloc))

(defun normbind_failany (recv env ncx procs psloc)
  (debug "normbind_failany recv" recv)
  (let ( (dis (discrim recv))
         )
    (debug "normbind_failany dis" dis)
    (error_at psloc "unexpected binding normalization of instance of $1" (get_field :named_name dis))
    (assert_msg "@$@unexpected normalize binding" () recv)
))
(install_method discr_any_receiver normalize_binding normbind_failany)

(defun normbind_anybind (bind env ncx procs psloc)
  (debug "normbind_anybind bind=" bind)
  (let ( (dis (discrim bind))
         (symb (unsafe_get_field :binder bind)) 
         (sycmap  (unsafe_get_field :nctx_symbcachemap ncx))
         )
    (warning_strv psloc "bizarre?? constant reference to"
                  (unsafe_get_field :named_name symb))
    (debug "normbind_anybind bind=" bind "\n of dis=" dis)
    (warning_strv psloc "bizarre binding normalization for " (get_field :named_name dis))
    (let ( (kocc
            (instance class_nrep_constocc
                      :nrep_loc psloc
                      :nocc_ctyp ctype_value
                      :nocc_symb symb
                      :nocc_bind bind) ) )
      (debug "normbind_anybind kocc=" kocc)
      ;; cache the result & return it
      (mapobject_put sycmap symb kocc)
      (debug "normbind_anybind updated sycmap=" sycmap)
      ;; put the const occurrence if needed in the const list of each proc
      (foreach_pair_component_in_list
       (procs)
       (curpair curproc)
       (debug "normbind_anybind const curproc=" curproc)
       (assert_msg "check curproc" (is_a curproc class_nrep_anyproc) curproc)
       (let ( (clcont (instance class_reference :referenced_value kocc))
              (constlist (get_field :nrclop_constlist curproc)) )
         (debug "normbind_anybind constlist=" constlist)
         (foreach_pair_component_in_list
          (constlist)
          (curpaircl curcl)
          (if (== curcl kocc)
              (put_fields clcont :referenced_value ())))
         (let ( (newcl (get_field :referenced_value clcont)) )
           (when newcl 
             (debug "normbind_anybind newcl=" newcl)
             (list_append constlist newcl))) 
         ))
      (return kocc)
      )))
(install_method class_any_binding normalize_binding normbind_anybind)


;; normalize local formal bindings
(defun normbind_formalbind (bind env ncx procs psloc)
  (assert_msg "check bind" (is_a bind class_formal_binding) bind)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx))
         (symb (unsafe_get_field :binder bind))
         (syocc
                (instance class_nrep_locsymocc
                          :nrep_loc psloc
                          :nocc_ctyp (unsafe_get_field :fbind_type bind) 
                          :nocc_symb symb
                          :nocc_bind bind) ) 
         )
          ;; cache the result & return it
    (mapobject_put sycmap symb syocc)
    (debug "normbind_formalbind updated sycmap=" sycmap 
           "\n.. syocc=" syocc "\n.. psloc=" psloc)
    syocc
    ))
(install_method class_formal_binding  normalize_binding normbind_formalbind)

;; normalize local let binding

(defun normbind_letbind (bind env ncx procs psloc)
  (assert_msg "check bind" (is_a bind class_let_binding) bind)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx))
         (symb (unsafe_get_field :binder bind))
         (syocc
                (instance class_nrep_locsymocc
                          :nrep_loc psloc
                          :nocc_ctyp (unsafe_get_field :fbind_type bind) 
                          :nocc_symb symb
                          :nocc_bind bind) ) 
         )
    ;; cache the result & return it
    (debug "normbind_letbind bind=" bind "\n.. syocc=" syocc "\n.. psloc=" psloc)
    (shortbacktrace_dbg "normbind_letbind" 20)
    (mapobject_put sycmap symb syocc)
    (debug "normbind_letbind updated sycmap=" sycmap "\n.. syocc=" syocc)
    syocc
    ))
(install_method class_let_binding  normalize_binding normbind_letbind)


;;; normalize local fixed binding
(defun normbind_fixbind (bind env ncx procs psloc)
  (debug "normbind_fixbind bind=" bind)
  (assert_msg "check bind" (is_a bind class_fixed_binding) bind)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sycmap  (unsafe_get_field :nctx_symbcachemap ncx))
         (symb (unsafe_get_field :binder bind))
         (fixdat (unsafe_get_field :fixbind_data bind))
         )
    (debug "normbind_fixbind fixdat=" fixdat "\n.. psloc=" psloc)
    (when (null fixdat)
      (debug "normbind_fixbind strange bind=" bind)
      (error_at psloc "unresolved forward fixed reference to $1"
                  (unsafe_get_field :named_name symb)
                  )
      )
    (assert_msg "normbind_fixbind check fixdat" (is_a fixdat class_nrep_bound_data) fixdat)
    ;; cache the result & return it
    (mapobject_put sycmap symb fixdat)
    (debug "normbind_fixbind updated sycmap=" sycmap " symb=" symb " fixdat=" fixdat "\n.. psloc=" psloc)
    fixdat))
(install_method class_fixed_binding  normalize_binding normbind_fixbind)


;; normalize a define-d binding
(defun normbind_definedvalbind (bind env ncx procs psloc)
  (debug "normbind_definedvalbind bind=" bind " psloc=" psloc)
  (assert_msg "check bind" (is_a bind class_defined_value_binding) bind)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sycmap  (unsafe_get_field :nctx_symbcachemap ncx))
         (symb (unsafe_get_field :binder bind))
         (curproc (get_field :nctx_curproc ncx))
         (syconst (instance class_nrep_defined_constant
                            :nrep_loc psloc
                            :nconst_sval symb
                            :nconst_data ()
                            :nconst_proc curproc
                            :nconst_defbind bind
                            ))
         )
    (debug "normbind_definedvalbind ncx=" ncx
           "\n env=" env " procs=" procs)
    ;; cache the result & return it
    (mapobject_put sycmap symb syconst)
    (put_fields bind :fixbind_data syconst)
    (debug "normbind_definedvalbind updated sycmap=" sycmap " syconst=" syconst 
           "\n.. bind=" bind "\n.. psloc=" psloc)
    (if (is_non_empty_list procs)
        (assert_msg "normbind_definedvalbind check no procs" () procs)
    (return syconst)
    )))
(install_method class_defined_value_binding normalize_binding normbind_definedvalbind)



;; normalize defined macro binding
(defun normbind_defmacrobind (bind env ncx procs psloc)
  (debug "normbind_defmacrobind bind=" bind "\n.. env=" env "\n.. ncx=" debug_less ncx 
         "\n.. procs=" debug_less procs "\n.. psloc=" psloc)
  (shortbacktrace_dbg "normbind_defmacrobind" 12)
  (assert_msg "check bind" (is_a bind class_defined_macro_binding) bind)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sycmap  (unsafe_get_field :nctx_symbcachemap ncx))
         (symb (unsafe_get_field :binder bind))
         (curproc (get_field :nctx_curproc ncx))
         (modctx (get_field :nctx_modulcontext ncx))
         (mdata (get_field :mbind_data bind))
         )
    (debug "normbind_defmacrobind mdata=" mdata)
    (when (is_non_empty_list procs)
      (assert_msg "normbind_defmacrobind bad procs" () procs))
    (when (is_not_a mdata class_nrep_dataclosure)
      (error_at psloc "insane use of undefined or ill-defined macro $1; macro uses should be operator-like." (get_field :named_name symb))
      (assert_msg "normbind_defmacrobind bad macro data while bootstrapping" 
                  (not (melt_is_bootstrapping)) 
                  mdata bind (discrim bind))
      (return)
      )
    (mapobject_put sycmap symb mdata)
    (return mdata)
    ))
(install_method class_defined_macro_binding normalize_binding normbind_defmacrobind)



;; normalize local constructed binding
(defun normbind_constructbind (bind env ncx procs psloc)
  (assert_msg "check bind" (is_a bind class_normal_constructor_binding) bind)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sycmap  (unsafe_get_field :nctx_symbcachemap ncx))
         (symb (unsafe_get_field :binder bind))
         (nletrec (get_field :nconsb_nletrec bind))
         )
          (debug "normbind_constructbind nletrec" nletrec)
          (assert_msg "normbind_constructbind  check nletrec" (is_a nletrec class_nrep_letrec) nletrec)
          (let ( (nlocsyms (get_field :nletrec_locsyms nletrec))
                 (ourlocsym ())
                 )
            (debug "normbind_constructbind nlocsyms" nlocsyms)
            ;; find the right locsym in nlocsyms and cache it
            (foreach_in_multiple
             (nlocsyms)
             (curlocsym :long syix)
             (when (== (get_field :nocc_bind curlocsym) bind)
                   (setq syix -9999)    ;to exit the loop [-1 don't work!]
                   (setq ourlocsym curlocsym))
             )
            (debug "normbind_constructbind ourlocsym" ourlocsym)
            (assert_msg "normbind_constructbind should have ourlocsym"
                        (is_a ourlocsym class_nrep_locsymocc) ourlocsym)
            ;; cache the result & return it
            (mapobject_put sycmap symb ourlocsym)
            (debug "normbind_constructbind updated sycmap=" sycmap " symb=" symb " ourlocsym=" ourlocsym)
            (return ourlocsym)
)))
(install_method class_normal_constructor_binding normalize_binding normbind_constructbind)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; For symbols which are imported from a previous environment 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)
  (debug "normexp_symbol recv=" recv 
         "\n.. env=" debug_more env
         "\n.. ncx=" ncx
         "\n.. psloc=" psloc 
         )
  (shortbacktrace_dbg "normexp_symbol" 32)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (assert_msg "check recv" (is_a recv class_symbol) recv)
  (multicall
   (bind procs gotenv)
   (find_enclosing_env env recv)
   (debug "normexp_symbol after find_enclosing_env bind=" debug_more bind 
          "\n.. procs=" debug_less procs "\n.. gotenv=" debug_more gotenv
          "\n.. env=" debug_more env "\n.. recv=" recv)
   (assert_msg "normexp_symbol check recv" (is_a recv class_symbol) recv)
   (let ( (modctx  (unsafe_get_field :nctx_modulcontext ncx))
          (valbindmap (unsafe_get_field :nctx_valbindmap ncx))
          (valuelist (unsafe_get_field :nctx_valuelist ncx))
          (symbname (get_field :named_name recv))
          )
     (if (null psloc)
         (shortbacktrace_dbg "normex_symbol null psloc" 10)
       )
     (when (null bind)
       (error_at psloc "unknown name $1; symbol is not bound"
                   symbname)
       (shortbacktrace_dbg "normexp_symbol null bind" 15)
       (debug "normexp_symbol bad name recv=" recv "\n.. env=" debug_more env)
       (debug "normexp_symbol bad name envprev=" debug_more (get_field :env_prev env))
       (debug "normexp_symbol bad name envprev2=" debug_more (get_field :env_prev (get_field :env_prev env)))
       (debug "normexp_symbol bad name envprev3=" (get_field :env_prev  (get_field :env_prev (get_field :env_prev env))))
       (if (melt_is_bootstrapping)
           (assert_msg "@$@normexp_symbol is failing while bootstrapping" () recv env))
       (return () ()))
     ;;
     (if (is_a bind class_normal_magic_binding)
         (let ( (magval (get_field :nmagic_value bind))
               )
           (debug "normexp_symbol magicbind magval=" magval)
           (if (is_a magval discr_normalizing_closure)
               (multicall
                (nval nbind)
                (magval env ncx psloc)
                (debug "normexp_symbol magicbind nval=" nval " nbind=" nbind)
                (return nval nbind))
             (progn
               (debug "normexp_symbol magicbind bind=" bind "\n gives magval=" magval)
               (return magval ())
             ))
           ))
     ;;
     (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx))
            (syca (mapobject_get sycmap recv)) )
       (assert_msg "check sycmap" (is_mapobject sycmap) sycmap)
       (debug "normexp_symbol syca=" syca "\n.. for recv=" recv "\n.. bind=" bind)
       (cond 
        ;; check if in the cache
        (syca 
         (return syca ()))   ;already cached
        ;;
        ;; value binding, get/put it into the map
        ( (is_a bind class_value_binding)
          (let ( (bvar (mapobject_get valbindmap bind)) 
                 (val (get_field :vbind_value bind))
                 )
            (debug "normexp_symbol value bind=" bind 
                   "\n.. procs=" procs "\n.. bvar=" bvar "\n.. val=" val)
            (if (null bvar)
                (let ( (newbvar 
                        (cond ( (is_a modctx class_running_extension_module_context)
                                (let
                                    ( (reglitval (register_literal_value val  modctx))
                                      (nlitval (instance class_nrep_literalnamedvalue
                                                         :nlitval_regval reglitval
                                                         :nlitval_symbol recv))
                                      )
                                  (debug "normexp_symbol nlitval=" nlitval)
                                  nlitval
                                  )
                                )
                              (:else
                               (instance class_nrep_importedval
                                         :nrep_loc psloc
                                         :nimport_symb recv
                                         :nimport_sydata (normal_symbol_data recv ncx psloc)))))
                       )
                  (mapobject_put valbindmap bind newbvar)
                  (setq bvar newbvar)
                  (list_append valuelist newbvar)
                  (debug "normexp_symbol newbvar=" newbvar "\n.. valuelist=" valuelist)
                  ))
            ;; if procs is a non-empty list, symbol is a "closed"
            ;; constant for the value
            (debug "normexp_symbol recv=" recv "\n.. procs=" procs)
            (if (and (is_list procs)
                     (is_pair (list_first procs)))
                (let ( (fxocc
                        (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 "normexp_symbol const value fxocc=" fxocc "\n.. recv=" recv
                         "\n.. updated sycmap=" sycmap "\n.. procs=" debug_less procs "\n.. for symbname=" symbname)
                  ;; put the const occurrence if needed in the const
                  ;; list of each proc
                  (foreach_pair_component_in_list
                   (procs)
                   (curpairpro pr)
                   (debug "normexp_symbol const symbname=" debug_less symbname " pr=" debug_less pr)
                   (assert_msg "check pr" (is_a pr class_nrep_anyproc) pr)
                   (cond ( (is_a pr class_nrep_routproc)
                           (let ( (clcont
                                   (instance class_reference :referenced_value fxocc))
                                  (cnstlist (get_field :nrclop_constlist pr)) )
                             (debug "normexp_symbol cnstlist=" cnstlist "\n.. pr=" pr "\n.. recv=" recv)
                             (foreach_pair_component_in_list
                              (cnstlist)
                              (curpaircx cx) 
                              (when (== cx fxocc)
                                (put_fields clcont :referenced_value ())))
                             (let ( (newcl (get_field :referenced_value clcont)) )
                               (when newcl 
                                 (debug "normexp_symbol newcl=" newcl)
                                 (list_append cnstlist newcl))) 
                             ))
                         ( (is_a pr class_nrep_hookproc)
                           (let ( (hkclobindlist (get_field :nrclop_clobindlist pr))
                                  (foundbind ())
                                  )
                             (debug "normexp_symbol hkclobindlist=" hkclobindlist)
                             (assert_msg "check hkclobindlist" (is_list hkclobindlist) hkclobindlist)
                             (foreach_pair_component_in_list 
                              (hkclobindlist)
                              (curpairbndhc curbnd)
                              (assert_msg "check curbnd" (is_a curbnd class_any_binding) curbnd)
                              (if (== curbnd bind) (setq foundbind curbnd)))
                             ;; append the new binding if not found
                             (when (null foundbind) 
                               (list_append hkclobindlist bind)
                               (debug "normexp_symbol recv=" recv
                                      "\n.. updated hkclobindlist=" hkclobindlist)
                               )
                             ))
                         (:else
                          (debug "normexp_symbol unexpected pr=" pr "\n... of discrim: " (discrim pr))
                          (assert_msg "normexp_symbol unexpected closing procedure" () pr)
                          )
                         )
                   )                    ;end foreach in procs
                  (return fxocc ())
                  )
              ;; otherwise symbol is the direct value
              (progn
                ;; cache the result
                (mapobject_put sycmap recv bvar)
                (debug "normexp_symbol local value bvar=" bvar "\n.. updated sycmap=" sycmap "\n.. symbname=" symbname)
                (return bvar ())
                )
              )))
        ;;
        ;; module variables
        ( (is_a bind class_normal_module_variable_binding)
          (debug "normexp_symbol variable binding bind=" bind)
          (let ( (nmodvar (instance class_nrep_modulevarocc
                                   :nmodvar_bind bind))
                 )
            ;; cache the result
            (mapobject_put sycmap recv nmodvar)
            (debug "normexp_symbol module variable occurrence nmodvar=" nmodvar  
                   "\n.. updated sycmap=" sycmap)
            (return nmodvar ())
          ))
        ;;
        ;; the procs is a non-empty list, so the symbol is closed
        ( (and (is_list procs)
               (is_pair (list_first procs)))
          (debug "normexp_symbol closed procs=" procs "\n.. bind=" bind)
          ;; 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_at psloc
                                "closed variable $1 has non value ctype $2 (boxing required)"
                                (unsafe_get_field :named_name recv)
                                (get_field :named_name bty)
                                )))
            (setq bty ctype_value)
            (if (is_a bind class_fixed_binding)
                (let ( (fxocc
                        (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 "normexp_symbol fxocc=" fxocc " updated sycmap=" sycmap)
                  ;; put the const occurrence if needed in the const list of each proc
                  (foreach_pair_component_in_list
                   (procs)
                   (curpairproc curproc)
                   (debug "normexp_symbol curproc=" curproc)
                   (assert_msg "check curproc" (is_a curproc class_nrep_anyproc) curproc)
                   (cond 
                    ( (is_a curproc class_nrep_routproc)
                      (let ( (clcont
                              (instance class_reference :referenced_value fxocc))
                             (cnstprocl (get_field :nrclop_constlist curproc)) )
                        (foreach_pair_component_in_list
                         (cnstprocl)
                         (curpairprocl cx) 
                         (when (== cx fxocc)
                           (put_fields clcont :referenced_value ()) ()))
                        (let ( (newcl (get_field :referenced_value clcont)) )
                          (when newcl 
                            (debug "normexp_symbol newcl=" newcl)
                            (list_append cnstprocl newcl))) 
                        ))
                    ( (is_a curproc class_nrep_hookproc)
                      (debug "normexp_symbol curproc=" curproc "\n recv=" recv "\n bind=" bind 
                             "\n fxocc=" fxocc)
                      (let ( (hkclobindlist (get_field :nrclop_clobindlist curproc))
                             (foundbind ())
                             )
                        (debug "normexp_symbol hkclobindlist=" hkclobindlist)
                        (assert_msg "check hkclobindlist" (is_list hkclobindlist) hkclobindlist)
                        (foreach_pair_component_in_list 
                         (hkclobindlist)
                         (curpairbndhc curbnd)
                         (assert_msg "check curbnd" (is_a curbnd class_any_binding) curbnd)
                         (if (== curbnd bind) (setq foundbind curbnd)))
                        (when (null foundbind)
                          (list_append hkclobindlist bind)
                          (debug "normexp_symbol updated hkclobindlist=" hkclobindlist))
                        ))
                    ;;
                    (:else
                     (debug "normexp_symbol bad curproc=" curproc)
                     (assert_msg "normexp_symbol unexpected curproc" () curproc)
                     ))
                   )                    ;end foreach_pair_component_in_list
                  (debug "normexp_symbol return fxocc=" fxocc)
                  (return fxocc ())
                  )
              ;; else bind is not a class_fixed_binding
              (let ( (clocc 
                      (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)
                (debug "normexp_symbol updated sycmap=" sycmap " clocc=" clocc)
                ;; put the closed occurrence if needed in the closed list of each proc
                (foreach_pair_component_in_list  
                 (procs)
                 (curpair curproc)
                 (assert_msg "check curproc" (is_a curproc class_nrep_anyproc) curproc)
                 (let ( (clcont (instance class_reference :referenced_value clocc))
                        (clobindl (get_field :nrclop_clobindlist curproc)) )
                   (foreach_pair_component_in_list 
                    (clobindl)
                    (curbndpair clbnd) 
                    (when (== clbnd bind)
                      (put_fields clcont :referenced_value ())))
                   (let ( (newcl (get_field :referenced_value clcont)) )
                     (if newcl (list_append clobindl bind))) 
                   ))
                (return clocc ())
                )))) 
        ;;
        ;; dispatch the binding
        (:else 
         (debug "normexp_symbol before normalize_binding bind=" bind " for recv=" recv " psloc=" psloc)
         (let ( (resnormbind 
                 (normalize_binding bind env ncx procs psloc))
                )
           (debug "normexp_symbol after normalize_binding resnormbind=" resnormbind
                  " for bind=" bind " recv=" recv " psloc=" psloc)
           (return resnormbind ())
           )))))))

(install_method class_symbol normal_exp normexp_symbol)


;;;
(defun gectyp_symocc (recv env)
  (assert_msg "check recv" (is_a recv class_nrep_symocc) recv)
  (unsafe_get_field :nocc_ctyp recv)
  )
(install_method class_nrep_symocc get_ctype gectyp_symocc)


;;;
(defun gectyp_modvarocc (recv env)
  (assert_msg "check recv" (is_a recv class_nrep_modulevarocc) recv)
  (return ctype_value)
  )
(install_method class_nrep_modulevarocc get_ctype gectyp_modvarocc)


;;; normalize a class - used in particular in normalization of get_field
;; this does not work well when the class's name is locally rebound,
;; which rarely happens in practice
(defun normexp_class (recv env ncx psloc)
  (debug "normexp_class recv" recv)
  (assert_msg "check recv" (is_a recv class_class) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check nctxt" (is_a ncx class_normalization_context) ncx)
  (let ( (clasymb (get_symbolstr (unsafe_get_field :named_name recv))) 
         (clabind (find_env env clasymb))
         )
    (debug "normexp_class clabind" clabind)
    (cond ( (is_a clabind class_class_binding)
            (let ( (normcla (normexp_symbol clasymb env ncx psloc)) )
              (debug "normexp_class normcla class data inst" normcla)
              (assert_msg "check normcla" 
                          (or 
                           (is_a normcla class_nrep_datainstance)
                           (is_a normcla class_nrep_constocc)
                           )
                          normcla
                          )
              (return normcla)
              ))
          ( (is_a clabind class_value_binding)
            (assert_msg "check clabind value" (== recv (unsafe_get_field :vbind_value clabind)) clabind recv)
            (let ( (normcla (normexp_symbol clasymb env ncx psloc)) )
              (debug "normexp_class normcla class value" normcla)
              ;; normcla can be a class_nrep_constocc or a class_nrep_importedval ...
              (assert_msg "check normcla" (is_a normcla class_nrep) normcla)
              (return normcla)
              ))
          (:else
           ;; this could happen if the class's name has been locally
           ;; rebound, But we don't really handle that. We might scan
           ;; the environment stack to find the real class binding and
           ;; normalize accordingly, but this won't happen often...
           (error_at psloc "class $1 incorrectly bound, perhaps locally rebound"_
                       (unsafe_get_field :named_name recv))
           (debug "normexp_class failed")
           (return)
           ))
    ))

(install_method class_class normal_exp normexp_class)


;;;;;;;;;;;;;;;;
;;; normalize a primitive invocation
(defun normexp_primitive (recv env ncx psloc)
  (debug "normexp_primitive recv" recv)
  (assert_msg "check prim recv" (is_a recv class_source_primitive) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check nctxt" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (unsafe_get_field :loca_location recv)) 
         (soper (unsafe_get_field :sprim_oper recv))
         (sargs (unsafe_get_field :sargop_args recv)) 
         )
    (assert_msg "check soper" (is_a soper class_primitive) soper)
    (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))
            )
       (assert_msg "check soptype" (is_a soptype class_ctype) soptype)
       (when (!=i nbarg (multiple_length sopformals))
             (error_at sloc "length mismatch between formals & actuals in primitive $1, got $2 arguments for $3 formals"_
                         sopnamstr nbarg (multiple_length sopformals))
             (return ()))
       (let ( (bmap (make_mapobject  discr_map_objects (+i 5 (/iraw (*i 3 nbarg) 2))))
              (expargs (make_multiple discr_multiple nbexp))
              )
         (foreach_in_multiple
          (sopformals)
          (forb :long ix)
          (assert_msg "check forb" (is_a forb class_formal_binding) forb)
          (debug "normexp_primitive forb" forb)
          (let ( (forarg (unsafe_get_field :binder forb))
                 (actarg (multiple_nth nargs ix)) 
                 (fortype (unsafe_get_field :fbind_type forb))
                 (actype (get_ctype actarg env))
                 )
            (debug "normexp_primitive actarg=" actarg " actype=" actype)
            (when (and (is_a fortype class_ctype)
                       (is_a actype class_ctype)
                       (!= fortype actype))
              (error_at sloc "type mismatch between formal $1 of ctype $2 and argument #$3 of ctype $4 in primitive $5"_
                        forarg (get_field :named_name fortype) ix (get_field :named_name actype) sopnamstr)
              )
            (mapobject_put bmap forarg actarg)
            ))
         (debug "normexp_primitive bmap in sopexp" bmap)
         (foreach_in_multiple
          (sopexp)
          (excu :long jx)
          (let ( (exval
                  (if (is_a excu class_symbol)
                      (let ( (bval (mapobject_get bmap excu)) )
                        (if (null bval) 
                            (progn 
                              ;; we could perhaps handle symbols which are not primitive arguments
                              ;; as some kind of closed constants, but this is rarely needed and
                              ;; requires a lot of work: the excu should then be the constant
                              ;; itself, and code should be generated to fill the primitive with
                              ;; non-symbol values.
                              (debug "normexp_primitive recv unexpected symbol in expansion recv=" recv "excu=" excu)
                              (error_at sloc "unexpected symbol $1 in primitive $2 expansion"_ 
                                        (unsafe_get_field  :named_name excu) sopnamstr)
                              ))
                        bval)
                    excu)) )
            (if (null exval)
                (progn
                  (warning_strv sloc "null expansion of primitive argument for"
                                sopnamstr)
                  (if (is_a excu class_named) 
                      (warning_strv sloc "null primitive original piece is"
                                    (unsafe_get_field :named_name excu)))
                  ))
            (multiple_put_nth expargs jx exval))
          )

         (debug "normexp_primitive soper" soper)
         (assert_msg "check soper is named" (is_a soper class_named) soper)
         (let ( (csym (clone_symbol soper))
                (nchunk (instance class_nrep_chunk
                                           :nrep_loc sloc
                                           :nchunk_expansion expargs
                                           :nchunk_oper soper
                                           :nexpr_ctyp soptype
                                           ))
                (cbind (instance class_normal_let_binding
                                 :letbind_loc sloc
                                 :binder csym
                                 :letbind_type soptype 
                                 :letbind_expr nchunk
                                 )) 
                (clocc (instance class_nrep_locsymocc
                                 :nrep_loc sloc
                                 :nocc_ctyp soptype
                                 :nocc_symb csym
                                 :nocc_bind cbind)) 
                )
           (debug "normexp_primitive nchunk=" nchunk)
           (if (is_list nbind) 
               (list_append nbind cbind)
             (progn
               (setq nbind (make_list discr_list))
               (list_append nbind cbind)
               ))
           (debug "normexp_primitive result clocc" clocc)
           (return
            clocc
            nbind
            )))))))

(install_method class_source_primitive normal_exp normexp_primitive)

;;;;;;;;;;;;;;;;
;;; normalize a hook call
(defun normexp_hook_call (recv env ncx psloc)
  (debug "normexp_hook_call recv=" recv)
  (shortbacktrace_dbg "normexp_hook_call" 15)
  (assert_msg "check recv" (is_a recv class_source_hook_call) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check nctxt" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (unsafe_get_field :loca_location recv)) 
         (shook (unsafe_get_field :shook_called recv))
         (sargs (unsafe_get_field :sargop_args recv))
         (hkname ())
         (hksymb ())
         (hkins ())
         (hkouts ())
         (hkctype ())
         (hkdescr ())
         (:long errorflag 0)
         (newenv (fresh_env env))
         )
    (debug "normexp_hook_call shook=" shook " sargs=" sargs)
    (match shook
           (?(instance class_source_defhook
                       :sdef_name ?shksymb
                       :sformal_args ?shkins
                       :shook_ctype ?shctype
                       :shook_out_formals ?shkouts)
             (setq hksymb shksymb)
             (assert_msg "check hksymb" (is_a hksymb class_symbol) hksymb)
             (setq hkname (get_field :named_name shksymb))
             (setq hkins shkins)
             (setq hkouts shkouts)
             (setq hkctype shctype)
             (debug "normexp_hook_call sourcedefhook hkname=" hkname
                    "\n hkins=" hkins "\n hkouts=" hkouts)
             )
           (?(some_hook_with_data
              ?(and ?dhkdescr 
                    ?(instance class_hook_descriptor
                               :named_name ?dhkname
                               :hookdesc_in_formals ?dhkins
                               :hookdesc_out_formals ?dhkouts
                               :hookdesc_ctype ?dhkctype)))
             (assert_msg "check dhkname" (is_string dhkname) dhkname)
             (setq hksymb (get_symbolstr dhkname))
             (setq hkname dhkname)
             (setq hkdescr dhkdescr)
             (setq hkins dhkins)
             (setq hkouts dhkouts)
             (setq hkctype dhkctype)
             (debug "normexp_hook_call valuehook hkname=" hkname
                    "\n.. hkins=" hkins
                    "\n.. hkouts=" hkouts
                    "\n.. hkctype=" hkctype)
             )
           (?_
            (error_at sloc "invalid hook call")
            (setq errorflag 1)
            (assert_msg "@$@unexpected hook, unimplemented" () shook)
            ))
    (assert_msg "check hkname" (is_string hkname) hkname)
    (assert_msg "check hkins" (is_multiple hkins) hkins)
    (assert_msg "check hkouts" (is_multiple hkouts) hkouts)
    (assert_msg "check hkctype" (is_a hkctype class_ctype) hkctype)
    (debug "normexp_hook_call hkname=" hkname " hksymb=" hksymb 
           "\n.. hkins=" hkins 
           "\n.. hkouts=" hkouts "\n.. hkctype=" hkctype)
    (assert_msg "check hkctype" (is_a hkctype class_ctype) hkctype)
    (let ( (:long nbins (multiple_length hkins))
           (:long nbouts (multiple_length hkouts))
           (hnamestr (get_field :named_name hkname))
           (sins (make_multiple discr_multiple nbins))
           (souts (make_multiple discr_multiple nbouts))
           (nouts (make_multiple discr_multiple nbouts))
           (hkbind (find_env env hksymb))
           )
      (debug "normexp_hook_call hkbind=" hkbind "\n hksymb=" hksymb)
      (assert_msg "check hkbind" (is_object hkbind) hkbind)
      (when (!=i (multiple_length sargs) (+i nbins nbouts))
        (error_at sloc "invalid operand arity $1 for hook call '$2' wanting #$3 inputs and #$4 outputs"_ 
                  (multiple_length sargs) hnamestr nbins nbouts)
        (return () ()))
      ;; extract and normalize the inputs
      (foreach_long_upto
       (0 (-i nbins 1))
       (:long inix)
       (multiple_put_nth sins inix (multiple_nth sargs inix))
       )
      (debug "normexp_hook_call sins=" sins)
      (multicall 
       (ninargs ninbinds)
       (normalize_tuple sins env ncx sloc)
       (debug "normexp_hook_call ninargs=" ninargs " ninbinds=" ninbinds)
       (if (null ninbinds)
           (setq ninbinds (make_list discr_list)))
       (foreach_pair_component_in_list
        (ninbinds)
        (curpair curinbind)
        (put_env newenv curinbind)
        )
       ;; check type compatibility of inputs
       (foreach_in_multiple
        (ninargs)
        (curinarg :long inix)
        (let ( (curinbind (multiple_nth hkins inix))
               (inbctyp (get_field :fbind_type curinbind))
               (inbinder (get_field :binder curinbind))
               (curinctyp (get_ctype curinarg newenv))
               )
          (debug "normexp_hook_call curinbind=" curinbind 
                 "\n curinarg=" curinarg "\n inix#" inix 
                 "\n inbctyp=" inbctyp "\n curinctyp=" curinctyp)
          (assert_msg "check inbctyp" (is_a inbctyp class_ctype) inbctyp)
          (assert_msg "check curinctyp" (is_a curinctyp class_ctype) curinctyp)
          (when (!= inbctyp curinctyp)
            (error_at sloc "type mismatch between input formal $1 of ctype $2 & argument #$3 of ctype $4 in hook call $5"
                        (get_field :named_name inbinder) (get_field :named_name inbctyp) 
                        inix (get_field :named_name curinctyp) hnamestr)
            (setq errorflag 1)
            )
          ))
       (debug "normexp_hook_call errorflag=" errorflag " after checking ninargs=" ninargs)
       ;;
       ;; extract and normalize the outputs
       (foreach_long_upto
        (0 (-i nbouts 1))
        (:long outix)
        (let ( (curoutarg (multiple_nth sargs (+i outix nbins)))
               (curoutbind (multiple_nth hkouts outix))
               (outbctyp (get_field :fbind_type curoutbind))
               (outbinder (get_field :binder curoutbind))
               )
          (debug "normexp_hook_call curoutarg=" curoutarg
                 "\n curoutbind=" curoutbind "\n outix#" outix)
          (multiple_put_nth souts outix curoutarg)
          (cond 
           ( (is_a curoutarg class_symbol)
             (let ( (noutvar (normexp_symbol curoutarg env ncx sloc)) 
                    (varoutctyp (get_ctype noutvar env))
                    )
               (debug "normexp_hook_call noutvar=" noutvar " varoutctyp=" varoutctyp)
               (when (is_not_a noutvar class_nrep_locsymocc)
                 (error_at sloc "invalid output variable $1 for hook $2"_ (get_field :named_name curoutarg) hnamestr)
                 (setq errorflag 1))             
               (assert_msg "check varoutctyp" (is_a varoutctyp class_ctype) varoutctyp)
               (when (!= varoutctyp outbctyp)
                 (error_at sloc "incompatible output formal $1 ctype $2 expecting $3 for hook $4"_ 
                           (get_field :named_name outbinder) 
                           (get_field :named_name varoutctyp) 
                           (get_field :named_name outbctyp) hnamestr)
                 (setq errorflag 1)
                 )
               (multiple_put_nth nouts outix noutvar)
               ))
           (:else
            (error_at sloc "hook output argument is not a symbol for formal output $1 of hook $2" (unsafe_get_field :named_name outbinder) hnamestr)
            (setq errorflag 1)
            ))
          ))
       (debug "normexp_hook_call  errorflag=" errorflag " souts=" souts " nouts=" nouts)
       (if errorflag 
           (return () ()))
       ;;
       (debug "normexp_hook_call hksymb=" hksymb "\n hkbind=" hkbind)
       (let (
             (nhook (normexp_symbol hksymb env ncx sloc))
             (nhkcall (instance class_nrep_hook_call
                                :nrep_loc sloc
                                :nexpr_ctyp hkctype
                                :nhook_name hkname
                                :nhook_called nhook
                                :nexpr_args ninargs
                                :nhook_outs nouts
                                :nhook_descr hkdescr
                                ))
             )
         (debug "normexp_hook_call nhkcall=" nhkcall "\n.. nhook=" nhook 
                "\n.. hksymb=" hksymb "\n .. hkdescr=" hkdescr)
         (let ( (csym (clone_symbol hksymb))
                (cbind (instance class_normal_let_binding
                                 :letbind_loc sloc
                                 :binder csym
                                 :letbind_type hkctype
                                 :letbind_expr nhkcall
                                 )) 
                (clocc (instance class_nrep_locsymocc
                                 :nrep_loc sloc
                                 :nocc_ctyp hkctype
                                 :nocc_symb csym
                                 :nocc_bind cbind)) 
                )
           (debug "normexp_hook_call cbind=" cbind " clocc=" clocc)
           (list_append ninbinds cbind)
           (debug "normexp_hook_call result clocc=" clocc 
                  " ninbinds=" ninbinds)
           (return clocc ninbinds)
           ))))))
(install_method class_source_hook_call normal_exp normexp_hook_call)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; normalize boxes


;;; mutable boxes
(defun normexp_box (recv env ncx psloc)
  (debug "normexp_box recv" recv)
  (assert_msg "check box recv" (is_a recv class_source_box) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (unsafe_get_field :loca_location recv)) 
         (sboxed (get_field :sboxed recv))
         )
    (multicall 
     (nboxed nbind)
     (normal_exp sboxed env ncx sloc)
     (debug "normexp_box nboxed=" nboxed " nbind=" nbind)
     (when (not (is_list nbind))
       (setq nbind (list))
       (debug "normexp_box set nbind=" nbind))
     (let ( (nctyp (get_ctype nboxed env))
            (autoboxdiscr (get_field :ctype_autoboxdiscr nctyp))
            )
       (assert_msg "normexp_box check nctyp" (is_a nctyp class_ctype) nctyp)
       (debug "normexp_box nctyp=" nctyp " autoboxdiscr=" autoboxdiscr)
       (when (is_not_a autoboxdiscr class_discriminant)
         (error_at sloc "non-BOX-able stuff of ctype $1"
                     (get_field :named_name nctyp))
         (return))
       (let (
             (boxer
              (cond
               ( (== nctyp ctype_value)
                 (setq autoboxdiscr ())
                 '"/*boxvalue*/ meltgc_new_reference"
                 )
               ( (is_a nctyp class_ctype_plain)
                 (let ( (boxing (get_field :ctypp_boxing nctyp))
                        )
                   boxing
                   ))
               ( (is_a nctyp class_ctype_gty)
                 (let ( (boxfun (get_field :ctypg_boxfun nctyp))
                        )
                   boxfun
                   ))
               (:else
                (error_at sloc "unexpected ctype $1 for BOX"
                            (get_field :named_name nctyp))))
              )
             )
         (debug "normexp_box boxer=" boxer)
         (let ( 
               (csym (clone_symbol 'box))
               (nchunk (instance class_nrep_chunk
                                 :nrep_loc sloc
                                 :nchunk_oper 'box
                                 :nexpr_ctyp ctype_value
                                 :nchunk_expansion
                                 (if autoboxdiscr
                                     (let 
                                         ( (predefdiscr
                                            (normal_predef autoboxdiscr ncx sloc
                                                           "autoboxing discriminant"))
                                           )
                                       (tuple
                                        (clone_with_discriminant '"/*full boxing*/ " discr_verbatim_string)
                                        (clone_with_discriminant boxer discr_verbatim_string)
                                        (clone_with_discriminant '"((meltobject_ptr_t) (" discr_verbatim_string)
                                        predefdiscr
                                        (clone_with_discriminant '"), (" discr_verbatim_string)
                                        nboxed
                                        (clone_with_discriminant '"))" discr_verbatim_string)
                                        ))
                                   (tuple
                                        (clone_with_discriminant '"/*short boxing*/ " discr_verbatim_string)
                                    (clone_with_discriminant boxer discr_verbatim_string)
                                    (clone_with_discriminant '"(" discr_verbatim_string)
                                    nboxed
                                    (clone_with_discriminant '")" discr_verbatim_string)
                                    )
                                   )))
               (cbind (instance class_normal_let_binding
                                :letbind_loc sloc
                                :binder csym
                                :letbind_type ctype_value
                                :letbind_expr nchunk
                                ))
               (clocc (instance class_nrep_locsymocc
                                :nrep_loc sloc
                                :nocc_ctyp ctype_value
                                :nocc_symb csym
                                :nocc_bind cbind))
               )
           (debug "normexp_box nchunk=" nchunk " clocc="  clocc)
           (list_append nbind cbind)
           (debug "normexp_box return clocc=" clocc " nbind=" nbind)
           (return clocc nbind)
           ))))))
(install_method class_source_box normal_exp normexp_box)


;;; constant boxes
(defun normexp_constbox (recv env ncx psloc)
  (debug "normexp_box recv" recv)
  (assert_msg "check box recv" (is_a recv class_source_constant_box) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (unsafe_get_field :loca_location recv)) 
         (sboxed (get_field :sboxed recv))
         )
    (multicall 
     (nboxed nbind)
     (normal_exp sboxed env ncx sloc)
     (debug "normexp_constbox nboxed=" nboxed " nbind=" nbind)
     (when (not (is_list nbind))
       (setq nbind (list))
       (debug "normexp_constbox set nbind=" nbind))
     (let ( (nctyp (get_ctype nboxed env))
            (autoboxdiscr (get_field :ctype_autoconstboxdiscr nctyp))
            )
       (assert_msg "normexp_constbox check nctyp" (is_a nctyp class_ctype) nctyp)
       (debug "normexp_constbox nctyp=" nctyp " autoboxdiscr=" autoboxdiscr)
       (when (is_not_a autoboxdiscr class_discriminant)
         (error_at sloc "non-CONSTANT_BOX-able stuff of ctype $1"
                     (get_field :named_name nctyp))
         (return))
       (let (
             (boxer
              (cond
               ( (is_a nctyp class_ctype_plain)
                 (let ( (boxing (get_field :ctypp_boxing nctyp))
                        )
                   boxing
                   ))
               ( (is_a nctyp class_ctype_gty)
                 (let ( (boxfun (get_field :ctypg_boxfun nctyp))
                        )
                   boxfun
                   ))
               (:else
                (error_at sloc "unexpected ctype $1 for BOX"_
                            (get_field :named_name nctyp))))
              )
             )
         (debug "normexp_box boxer=" boxer)
         (let ( 
               (csym (clone_symbol 'box))
               (nchunk (instance class_nrep_chunk
                                 :nrep_loc sloc
                                 :nchunk_oper 'box
                                 :nexpr_ctyp ctype_value
                                 :nchunk_expansion
                                 (if autoboxdiscr
                                     (let 
                                         ( (predefdiscr
                                            (normal_predef autoboxdiscr ncx sloc
                                                           "autoconstboxing discriminant"))
                                           )
                                       (tuple
                                        (clone_with_discriminant '"/*full constboxing*/ " discr_verbatim_string)
                                        (clone_with_discriminant boxer discr_verbatim_string)
                                        (clone_with_discriminant '"((meltobject_ptr_t) (" discr_verbatim_string)
                                        predefdiscr
                                        (clone_with_discriminant '"), (" discr_verbatim_string)
                                        nboxed
                                        (clone_with_discriminant '"))" discr_verbatim_string)
                                        ))
                                   (tuple
                                        (clone_with_discriminant '"/*short constboxing*/ " discr_verbatim_string)
                                    (clone_with_discriminant boxer discr_verbatim_string)
                                    (clone_with_discriminant '"(" discr_verbatim_string)
                                    nboxed
                                    (clone_with_discriminant '")" discr_verbatim_string)
                                    )
                                   )))
               (cbind (instance class_normal_let_binding
                                :letbind_loc sloc
                                :binder csym
                                :letbind_type ctype_value
                                :letbind_expr nchunk
                                ))
               (clocc (instance class_nrep_locsymocc
                                :nrep_loc sloc
                                :nocc_ctyp ctype_value
                                :nocc_symb csym
                                :nocc_bind cbind))
               )
           (debug "normexp_constbox nchunk=" nchunk " clocc="  clocc)
           (list_append nbind cbind)
           (debug "normexp_constbox return clocc=" clocc " nbind=" nbind)
           (return clocc nbind)
           ))))))
(install_method class_source_constant_box normal_exp normexp_constbox)



;;;  unboxing
(defun normexp_unbox (recv env ncx psloc)
  (debug "normexp_unbox recv" recv)
  (assert_msg "check unbox recv" (is_a recv class_source_unbox) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (unsafe_get_field :loca_location recv)) 
         (sexp (get_field :sunbox_expr recv))
         (ctyp (get_field :sunbox_ctype recv))
         (cname (get_field :ctype_cname ctyp))
         )
    (debug "normexp_unbox ctyp=" ctyp)
    (assert_msg "check ctyp" (is_a ctyp class_ctype) ctyp)
    (let ( (unboxer 
            (cond ( (is_a ctyp class_ctype_plain)
                    (get_field :ctypp_unboxing ctyp))
                  ( (is_a ctyp class_ctype_gty)
                    (get_field :ctypg_unboxfun ctyp))
                  (:else
                   (error_at sloc "unexpected ctype $1 for UNBOX" 
                             (get_field :named_name ctyp))
                   (return))))
           )
      (debug "normexp_unbox unboxer=" unboxer " cname=" cname)
      (multicall 
       (nexp nbind)
       (normal_exp sexp env ncx sloc)
       (debug "normexp_unbox nexp=" nexp " nbind=" nbind)
       (when (not (is_list nbind))
         (setq nbind (list))
         (debug "normexp_unbox set nbind=" nbind))
       (let (
             (csym (clone_symbol 'unbox))
             (nchunk 
              (instance class_nrep_chunk
                        :nrep_loc sloc
                        :nchunk_oper 'unbox
                        :nexpr_ctyp ctyp
                        :nchunk_expansion
                        (tuple
                         (clone_with_discriminant '"/*unboxing*/ " discr_verbatim_string)
                         (clone_with_discriminant unboxer discr_verbatim_string)
                         (clone_with_discriminant '" ((melt_ptr_t)" discr_verbatim_string)
                         nexp
                         (clone_with_discriminant '")" discr_verbatim_string)
                         )))
             (cbind (instance class_normal_let_binding
                              :letbind_loc sloc
                              :binder csym
                              :letbind_type ctyp
                              :letbind_expr nchunk
                              ))
             (clocc (instance class_nrep_locsymocc
                              :nrep_loc sloc
                              :nocc_ctyp ctyp
                              :nocc_symb csym
                              :nocc_bind cbind))
             )
         (debug "normexp_unbox nchunk=" nchunk " clocc="  clocc)
         (list_append nbind cbind)
         (debug "normexp_unbox return clocc=" clocc " nbind=" nbind)
         (return clocc nbind)
         )))))
(install_method class_source_unbox normal_exp normexp_unbox)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; normalize a code_chunk
(defun normexp_code_chunk (recv env ncx psloc)
  (debug "normexp_code_chunk recv=" recv)
  (assert_msg "check code_chunk recv" (is_a recv class_source_codechunk) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check nctxt" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (unsafe_get_field :loca_location recv)) 
         (schk (unsafe_get_field :sch_chunks recv))
         (gsym (unsafe_get_field :sch_gensym recv))
         (csym (clone_symbol gsym))
         (bindlist (make_list discr_list))
         (newenv (fresh_env env))
         (csymstr 
          (let ( (sbuf (make_strbuf discr_strbuf)) )
            (add2sbuf_cident sbuf (get_field :named_name csym))
            (add2sbuf_strconst sbuf "__")
            (add2sbuf_longdec sbuf (get_int (get_field :csym_urank csym)))
            (strbuf2string discr_verbatim_string sbuf)
            ))
         (magicbind (let ( (mb (instance class_normal_magic_binding
                                         :binder gsym
                                         :nmagic_value csymstr))
                           )
                      (put_env newenv mb)
                      (debug "normexp_code_chunk magicbind=" mb)
                      mb))
         (nchk (let ( (nc 
                       (multiple_map 
                        schk
                        (lambda (curcomp :long curix)
                          (cond
                           ( (is_string curcomp)
                             (clone_with_discriminant curcomp discr_verbatim_string))
                           ( (is_a curcomp class_symbol)
                             (normal_exp curcomp newenv ncx sloc))
                           (:else
                            (debug "normexp_code_chunk curcomp=" curcomp " curix#" curix)
                            (multicall
                             (nexp nbind)
                             (normal_exp curcomp newenv ncx sloc)
                             (debug "normexp_code_chunk nexp=" nexp "\n.. nbind=" nbind)
                             (assert_msg "check nbind" (is_list_or_null nbind) nbind)
                             (let ( (compctyp (get_ctype nexp newenv))
                                    (cloc (or (get_field :loca_location curcomp) sloc))
                                    )
                               (debug "normexp_code_chunk compctyp=" compctyp)
                               (when (!= compctyp ctype_void)
                                 (error_at cloc
                                             "composite CODE_CHUNK element should be :void, got $1"
                                             (get_field :named_name compctyp))
                                 (return ())
                                 )
                               (let ( (wl (wrap_normal_let1 nexp nbind sloc))
                                      )
                                 (debug "normexp_code_chunk wl=" wl " curix#" curix)
                                 wl)))))))))
                 (debug "normexp_code_chunk nchk=" nc)
                 nc))
         (cbind (instance class_normal_let_binding
                          :letbind_loc sloc
                          :binder csym
                          :letbind_type ctype_void
                          :letbind_expr 
                          (instance class_nrep_chunk
                                    :nrep_loc sloc
                                    :nchunk_expansion nchk
                                    :nchunk_oper csym
                                    :nexpr_ctyp ctype_void
                                    ))) 
         (clocc (instance class_nrep_locsymocc
                          :nrep_loc sloc
                          :nocc_ctyp ctype_void
                          :nocc_symb csym
                          :nocc_bind cbind)) 
         )
    (debug "normexp_code_chunk schk=" schk "\n.. nchk=" nchk)
    (debug "normexp_code_chunk clocc=" clocc)
    (assert_msg "check nchk" (is_multiple nchk) nchk)
    (debug "normexp_code_chunk return clocc=" clocc " cbind=" cbind)
    (return clocc (list cbind))
    ))
(install_method class_source_codechunk normal_exp normexp_code_chunk)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; normalize an expr_chunk
(defun normexp_expr_chunk (recv env ncx psloc)
  (debug "normexp_expr_chunk recv=" recv)
  (assert_msg "check expr_chunk recv" (is_a recv class_source_exprchunk) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (unsafe_get_field :loca_location recv)) 
         (schk (unsafe_get_field :sch_chunks recv))
         (gsym (unsafe_get_field :sch_gensym recv))
         (ctyp (unsafe_get_field :sxch_ctype recv))
         (csym (clone_symbol gsym))
         (bindlist (make_list discr_list))
         (newenv (fresh_env env))
         (csymstr 
          (let ( (sbuf (make_strbuf discr_strbuf)) )
            (add2sbuf_cident sbuf (get_field :named_name csym))
            (add2sbuf_strconst sbuf "__")
            (add2sbuf_longdec sbuf (get_int (get_field :csym_urank csym)))
            (strbuf2string discr_verbatim_string sbuf)
            ))
         (magicbind (let ( (mb (instance class_normal_magic_binding
                                         :binder gsym
                                         :nmagic_value csymstr))
                           )
                      (put_env newenv mb)
                      (debug "normexp_expr_chunk magicbind=" mb)
                      mb))
         (listbinds (make_list discr_list))
         (listnchunks (make_list discr_list))
         (nchk (make_multiple discr_multiple (multiple_length schk)))
         )
    (debug "normexp_expr_chunk ctyp=" ctyp "\n schk=" schk)
    (assert_msg "check schk" (is_multiple schk) schk)
    (assert_msg "check ctyp" (is_a ctyp class_ctype) ctyp)
    (foreach_in_multiple 
     (schk)
     (srcomp :long six)
     (debug "normexp_expr_chunk six#" six " srcomp=" srcomp)
     (cond ( (is_a srcomp class_source)
             (multicall 
              (ncomp ncbind)
              (normal_exp srcomp newenv ncx sloc)
              (debug "normexp_expr_chunk six#" six " ncomp=" ncomp "\n.. ncbind=" ncbind)
              (assert_msg "check ncbind" (is_list_or_null ncbind) ncbind)
              (if ncbind (list_append2list listbinds ncbind))
              (if (is_list ncomp)
                  (list_append2list listnchunks ncomp)
                (list_append listnchunks ncomp))
              ))
           ( (is_a srcomp class_symbol)
             (multicall 
              (nsymb nsbind)
              (normal_exp srcomp newenv ncx sloc)
              (debug "normexp_expr_chunk nsymb=" nsymb " nsbind=" nsbind)
              (assert_msg "nsbind null" (null nsbind) nsbind)
              (list_append listnchunks nsymb)
             ))
           ( (is_string srcomp)
             (list_append listnchunks (make_string discr_verbatim_string srcomp))
             )
           (:else
            (list_append listnchunks srcomp)
            ))
     (debug "normexp_expr_chunk six#" six "\n updated listbinds=" listbinds
            "\n updated listnchunks=" listnchunks)
     )
    ;; end foreach_in_multiple
    (let ( (tupnchunk (list_to_multiple listnchunks discr_multiple))
           (nchunk (instance class_nrep_chunk
                             :nrep_loc sloc
                             :nchunk_expansion tupnchunk
                             :nchunk_oper csym
                             :nexpr_ctyp ctyp))
           (cbind  (instance class_normal_let_binding
                             :letbind_loc sloc
                             :binder csym
                             :letbind_type ctyp
                             :letbind_expr nchunk))
           (clocc (instance class_nrep_locsymocc
                            :nrep_loc sloc
                            :nocc_ctyp ctyp
                            :nocc_symb csym
                            :nocc_bind cbind)) 
           )
      (list_append listbinds cbind)
      (debug "normexp_expr_chunk with nchunk=" nchunk " gives clocc=" clocc " listbinds=" listbinds)
      (return clocc listbinds)
      ))) 
(install_method class_source_exprchunk normal_exp normexp_expr_chunk)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; normalize a cmatchexpr
(defun normexp_cmatchexpr (recv env ncx psloc)
  (debug "normexp_cmatchexpr recv" recv)
  (assert_msg "check recv" (is_a recv class_source_cmatchexpr) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (unsafe_get_field :loca_location recv)) 
         (scmat (unsafe_get_field :scmatx_cmatcher recv))
         (sargs (unsafe_get_field :sargop_args recv)) 
         )
    (assert_msg "check scmat" (is_a scmat class_cmatcher) scmat)
    (multicall 
     (nargs nbind)
     (normalize_tuple sargs env ncx sloc)
     (let ( (cmanamstr (unsafe_get_field :named_name scmat))
            ;; the outformals are really the "input" arguments for cmatchexpr
            (oformals (unsafe_get_field :amatch_out scmat))
            ;; the matchbind gives the result of the cmatchexpr
            (mabind (let ( (mb (unsafe_get_field :amatch_matchbind scmat)) )
                      (assert_msg "check mabind" (is_a mb class_formal_binding) mb)
                      mb))
            ;; the type of the cmatchexpr
            (otype (unsafe_get_field :fbind_type mabind))
            (sopexp (unsafe_get_field :cmatch_expoper scmat)) 
            (:long nbarg (multiple_length nargs))
            (:long nbexp (multiple_length sopexp))
            )
       (assert_msg "check otype" (is_a otype class_ctype) otype)
       (if (!=i nbarg (multiple_length oformals))
           (progn
             (error_at sloc "length mismatch between formals & actuals in cmatch $1 expr" 
                         cmanamstr)
             (return))
         )
       (let ( (bmap (make_mapobject  discr_map_objects (+i 5 (/iraw (*i 3 nbarg) 2))))
              (expargs (make_multiple discr_multiple nbexp))
              )
         (multiple_every
          oformals
          (lambda (forb :long ix)
            (assert_msg "check forb" (is_a forb class_formal_binding) forb)
            (debug "normexp_cmatchexpr forb" forb)
            (let ( (forarg (unsafe_get_field :binder forb))
                   (actarg (multiple_nth nargs ix)) 
                   (fortype (unsafe_get_field :fbind_type forb))
                   (actype (get_ctype actarg env))
                   )
              (debug "normexp_cmatchexpr actarg=" actarg " actype=" actype)
              (if (and (is_a fortype class_ctype)
                       (is_a actype class_ctype)
                       (!= fortype actype))
                  (progn
                    (error_at sloc 
                              "type mismatch between formals & actuals in cmatch $1 operator formal $2 actual ctype $3 expected ctype $4"_
                                  cmanamstr
                                  (unsafe_get_field :named_name forarg) 
                                  (unsafe_get_field :named_name actype) 
                                  (unsafe_get_field :named_name fortype))
                    ))
              (mapobject_put bmap forarg actarg)
              )))
         (debug "normexp_cmatchexpr bmap in sopexp" bmap)
         (multiple_every
          sopexp
          (lambda (excu :long jx)
            ;;(debug "normexp_cmatchexpr excu in sopexp" excu)
            (let ( (exval
                    (if (is_a excu class_symbol)
                        (let ( (bval (mapobject_get bmap excu)) )
                          (if (null bval) 
                              (progn 
;; we could perhaps handle symbols which are not primitive arguments
;; as some kind of closed constants, but this is rarely needed and
;; requires a lot of work: the excu should then be the constant
;; itself, and code should be generated to fill the primitive with
;; non-symbol values.
                                (debug "normexp_cmatchexpr unexpected symbol in expansion recv=" recv " excu=" excu)
                                (error_at sloc 
                                          "unexpected symbol in cmatch expression expansion $1 for $2"_
                                          (unsafe_get_field  :named_name excu)
                                          cmanamstr)
                                ))
                          bval)
                      excu)) )
              (if (null exval)
                  (progn
                    (warning_strv sloc "null expansion of cmatch expression argument for"
                                  cmanamstr)
                    (if (is_a excu class_named) 
                        (warning_strv sloc "null cmatch expression original piece is"
                                      (unsafe_get_field :named_name excu)))
                    ))
                                        ;(debug "normexp_cmatchexpr exval in sopexp" exval)
              (multiple_put_nth expargs jx exval))
            ))
         (let ( (csym (clone_symbol cmanamstr)) 
                (cbind (instance class_normal_let_binding
                                 :letbind_loc sloc
                                 :binder csym
                                 :letbind_type otype 
                                 :letbind_expr 
                                 (instance class_nrep_chunk
                                           :nrep_loc sloc
                                           :nchunk_expansion expargs
                                           :nchunk_oper scmat
                                           :nexpr_ctyp otype
                                           ))) 
                (clocc (instance class_nrep_locsymocc
                                 :nrep_loc sloc
                                 :nocc_ctyp otype
                                 :nocc_symb csym
                                 :nocc_bind cbind)) 
                )
           (if (is_list nbind) 
               (list_append nbind cbind)
             (progn
               (setq nbind (make_list discr_list))
               (list_append nbind cbind)
               ))
           (debug "normexp_cmatchexpr result clocc" clocc)
           (return
            clocc
            nbind
            )))))))

(install_method class_source_cmatchexpr normal_exp normexp_cmatchexpr)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; normalize a funmatchexpr
(defun normexp_funmatchexpr (recv env ncx psloc)
  (debug "normexp_funmatchexpr recv" recv)
  (assert_msg "check recv" (is_a recv class_source_funmatchexpr) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (unsafe_get_field :loca_location recv)) 
         (sfmat (unsafe_get_field :sfmatx_fmatcher recv))
         (sfbind (unsafe_get_field :sfmatx_fmatbind recv))
         (sargs (unsafe_get_field :sargop_args recv)) 
         (nbind (make_list discr_list))
         )
    (assert_msg "check sfmat" (is_a sfmat class_funmatcher) sfmat)
    (assert_msg "check sfbind" (is_a sfbind class_any_binding) sfbind)
    (debug "normexp_funmatchexpr sfbind" sfbind)
    (let ( (fmatsym (unsafe_get_field :binder sfbind)) )
      (assert_msg "check fmatsym" (is_a fmatsym class_symbol) fmatsym)
      (assert_msg "check good sfbind" (== sfbind (find_env env fmatsym)) sfbind fmatsym)
      (let ( (nfmat (normal_exp fmatsym env ncx psloc)) )
        (debug "normexp_funmatchexpr nfmat" nfmat)
        ;; should create a normlet binding to hold the nfmat's
        ;; fmatch_applyf field
        (let ( (csym (clone_symbol fmatsym))
               (cbind (instance class_normal_let_binding
                                :letbind_loc sloc
                                :binder csym
                                :letbind_type ctype_value 
                                :letbind_expr 
                                (instance class_nrep_unsafe_get_field
                                          :nrep_loc sloc
                                          :nuget_obj nfmat
                                          :nuget_field fmatch_applyf)
                                ))
               (clocc (instance  class_nrep_locsymocc
                                 :nrep_loc sloc
                                 :nocc_ctyp ctype_value
                                 :nocc_symb csym
                                 :nocc_bind cbind))
               )
          (list_append nbind cbind)
          (multicall 
           (nargs nargbind)
           (normalize_tuple sargs env ncx sloc)
           (debug "normexp_funmatchexpr nargs=" nargs " nargbind=" nargbind)
           (list_append2list nbind nargbind)
           (let (
                 (asym (clone_symbol fmatsym))
                 (abind  (instance class_normal_let_binding
                                   :letbind_loc sloc
                                   :binder asym
                                   :letbind_type ctype_value 
                                   :letbind_expr 
                                   (instance class_nrep_apply
                                             :nexpr_ctyp ctype_value
                                             :nrep_loc sloc
                                             :napp_fun clocc
                                             :nexpr_args nargs
                                             ))) 
                 (calocc  (instance  class_nrep_locsymocc
                                     :nrep_loc sloc
                                     :nocc_ctyp ctype_value
                                     :nocc_symb asym
                                     :nocc_bind abind
                                     )) 
                 )
             (list_append nbind abind)
             (debug "normexp_funmatchexpr final calocc=" calocc " nbind=" nbind)
             (return calocc nbind)
             )))))))
(install_method class_source_funmatchexpr normal_exp normexp_funmatchexpr)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; normalize an application
(defun normexp_apply (recv env ncx psloc)
  (debug "normexp_apply" " recv=" recv "\n.. env=" env "\n.. ncx=" ncx "\n.. psloc=" psloc)
  (shortbacktrace_dbg "normexp_apply" 18)
  (assert_msg "check apply recv" (is_a recv class_source_apply) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (unsafe_get_field :loca_location recv)) 
         (sfun (unsafe_get_field :sapp_fun recv))
         (sargs (unsafe_get_field :sargop_args recv))
         (sfusymb (if (is_a sfun class_symbol) sfun '_fun_))
         )
    (debug "normexp_apply sloc=" sloc "; sfun=" sfun)
    (multicall 
     (nfun nbindfun)
     (normal_exp sfun env ncx sloc)
     (debug "normexp_apply nfun=" nfun "\n nbindfun=" nbindfun)
     (assert_msg "check nbindfun" (is_list_or_null nbindfun) nbindfun)
     (let ( (nfunctyp (get_ctype nfun env)) 
            )
       (debug "normexp_apply nfunctyp" nfunctyp)
       (if (!= nfunctyp ctype_value)
           (progn 
             (debug "normexp_apply bad nfun=" nfun " sfun=" sfun " nfunctyp=" nfunctyp " recv=" recv)
             (error_at sloc "applied function should be a value, but has bad ctype $1" 
                         (get_field :named_name nfunctyp))
             (cond 
              ( (is_string sfun)
                (error_at sloc "bad applied string '$1', not a function"_ sfun))
              ( (is_a sfun class_named)
                (error_at sloc "bad applied function, named $1"_ 
                            (get_field :named_name sfun)))
              ( (is_a sfun class_located)
                (error_at (get_field :loca_location sfun) 
                          "here is the wrong applied function")))
             )))
     (debug "normexp_apply sloc=" sloc "; sargs=" sargs)
     (multicall
      (nargs nbindargs)
      (normalize_tuple sargs env ncx sloc)
      (debug "normexp_apply" " nargs=" nargs "\n.. nbindargs=" nbindargs
             "\n.. sargs=" sargs "\n.. sloc=" sloc)
      (assert_msg "check nbindargs" (is_list_or_null nbindargs) nbindargs)
      ;; if given the first argument should be a value
      (let ( (nargfirst (multiple_nth nargs 0)) 
             )
        (debug "normexp_apply nargfirst" nargfirst)
        (if nargfirst 
            (let ( (nargfirstctype (get_ctype nargfirst env)) 
                   )
              (debug "normexp_apply nargfirstctype=" nargfirstctype)
              (if (!= nargfirstctype ctype_value)
                  (error_at sloc
                            "first argument of function application should be a value not a $1" (get_field :named_name nargfirstctype))
                ))
          ))
      ;;
      (debug "normexp_apply" " before check_ctype_nargs, nargs=" nargs
             "\n.. env=" debug_less env "\n.. sloc=" sloc)
      (check_ctype_nargs nargs env sloc)
      (debug "normexp_apply" " after check_ctype_nargs sloc=" sloc)
      (setq nbindargs (list_append2list nbindargs nbindfun))
      ;; add a void binding to check interrupts
      (let ( (cintsym (clone_symbol sfusymb))
             (nchint (instance class_nrep_checksignal
                               :nrep_loc sloc))
             (cintbind (instance class_normal_let_binding
                                 :letbind_loc sloc
                                 :binder cintsym
                                 :letbind_type ctype_void
                                 :letbind_expr nchint))
             )
        (if (null nbindargs)
            (setq nbindargs (list cintbind))
          (list_append nbindargs cintbind))
        )
      (assert_msg "check nbindargs" (is_list nbindargs) nbindargs)
      ;;
      (let ( (csym (clone_symbol sfusymb))
             (cbind (instance class_normal_let_binding
                              :letbind_loc sloc
                              :binder csym
                              :letbind_type ctype_value 
                              :letbind_expr 
                              (instance class_nrep_apply
                                        :nrep_loc sloc
                                        :nexpr_ctyp ctype_value
                                        :napp_fun nfun
                                        :nexpr_args nargs
                                        ))) 
             (clocc  (instance  class_nrep_locsymocc
                                :nrep_loc sloc
                                :nocc_ctyp ctype_value
                                :nocc_symb csym
                                :nocc_bind cbind
                                )) 
             )
        (list_append nbindargs cbind)
        (return clocc nbindargs)
        )))))
(install_method class_source_apply normal_exp normexp_apply)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; normalize a message send
(defun normexp_msend (msnd env ncx psloc)
  (debug "normexp_msend msnd=" msnd)
  (assert_msg "check msnd" (is_a msnd class_source_msend) msnd)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (msrecv (unsafe_get_field :msend_recv msnd))
         (msargs (unsafe_get_field :sargop_args msnd))
         (selnam (unsafe_get_field :msend_selsymb msnd))
         (curproc (unsafe_get_field :nctx_curproc ncx))
         (sloc (unsafe_get_field :loca_location msnd))
         (nsel (normexp_symbol selnam env ncx sloc))
         (selbind (find_env env selnam))
         )
    (debug "normexp_msend curproc=" curproc " selbind=" selbind)
;;;; we should add the constant selector into the current routine's constant pool
    (multicall
     (nrecv nbindrecv)
     (normal_exp msrecv env ncx sloc)
     (assert_msg "check nbindrecv" (is_list_or_null nbindrecv) nbindrecv)
     ;; check that receiver is a value
     (let ( (ctypr (get_ctype nrecv env)) )
       (assert_msg "normexp_msend check ctypr " (is_a ctypr class_ctype) ctypr)
       (if (!= ctypr ctype_value)
           (error_at sloc "non value receiver for message send of selector $1"
                     (unsafe_get_field :named_name selnam)))
       )
     (multicall
      (nargs nbindargs)
      (normalize_tuple msargs env ncx sloc)
      (assert_msg "check nbindargs" (is_list_or_null nbindargs) nbindargs)
      ;; add a void binding to check interrupts
      (let ( 
             (cintsym (clone_symbol selnam))
             (nint (instance class_nrep_checksignal
                             :nrep_loc sloc))
             (cintbind (instance class_normal_let_binding
                                 :letbind_loc sloc
                                 :binder cintsym
                                 :letbind_type ctype_void
                                 :letbind_expr nint))
            )
        (if (is_list nbindargs)
            (list_append nbindargs cintbind)
          (setq nbindargs (list cintbind)))
        )
      ;;
      (setq nbindrecv (list_append2list nbindrecv nbindargs))
      (check_ctype_nargs nargs env sloc)
      (let ( (selformals
              (cond ( (is_a selbind class_selector_binding)
                      (get_field  :sdefsel_formals (get_field :sbind_selectordef selbind) 
                                  )
                      )
                    ( (is_a selbind class_value_binding)
                      (let ( (valsel (get_field :vbind_value selbind)) )
                        (assert_msg "check valsel" (is_a valsel class_selector) valsel)
                        (get_field  :sel_signature valsel))
                      )
                    (:else 
                     (assert_msg "invalid selbind" () selbind)
                     ())))
             (csym (clone_symbol selnam)) 
             (nsend (instance class_nrep_msend
                              :nrep_loc sloc
                              :nexpr_ctyp ctype_value
                              :nsend_sel nsel
                              :nsend_recv nrecv
                              :nexpr_args nargs
                              )) 
             (cbind (instance class_normal_let_binding
                              :letbind_loc sloc
                              :binder csym
                              :letbind_type ctype_value 
                              :letbind_expr nsend))
             (clocc  (instance  class_nrep_locsymocc
                                :nrep_loc sloc
                                :nocc_ctyp ctype_value
                                :nocc_symb csym
                                :nocc_bind cbind)) 
             )
        (debug "normexp_msend nsend middle" nsend)
        (assert_msg "check nrecv" (is_object nrecv) nrecv)
        (if (is_multiple selformals)
            (let ( (recvformal (multiple_nth selformals 0))
                   (:long nbformals (multiple_length selformals))
                   )
              (debug "normexp_msend" selformals)
              (assert_msg "check recvformal" (== (get_field :fbind_type recvformal) ctype_value) recvformal)
              (if (!=i nbformals (+i 1 (multiple_length nargs)))
                  (error_at sloc "unexpected number of arguments for method $1 with $2 formals"
                            (get_field :named_name selnam) nbformals)
                )
              (foreach_in_multiple 
               (nargs)
               (curnarg :long nix)
               (let ( (curformal (multiple_nth selformals (+i nix 1)))
                      (curctyp (get_ctype curnarg env))
                      (formctyp (get_field :fbind_type curformal))
                      (formbinder (get_field :binder curformal))
                      )
                 (assert_msg "check curformal" (is_a curformal class_formal_binding) curformal)
                 (if (!= curctyp formctyp)
                     (progn
                       (warning_strv sloc "c-type mismatch in method send argument"
                                     (get_field :named_name selnam))
                       (inform_strv sloc "mismatched method formal name"
                                    (get_field :named_name formbinder))
                       (inform_strv sloc "mismatched method actual type"
                                    (get_field :named_name curctyp))
                       (inform_strv sloc "mismatched method expected type"
                                    (get_field :named_name formctyp))
                       )
                   )
                 ))))
        (unsafe_put_fields clocc :nocc_bind cbind)
        (if (not (is_list nbindrecv))
            (setq nbindrecv (make_list discr_list)))
        (list_append nbindrecv cbind)
        (debug "normexp_msend final nbindrecv=" nbindrecv " clocc=" clocc)
        (return clocc nbindrecv)
        )))))
(install_method class_source_msend normal_exp normexp_msend)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; normalize a return
(defun normexp_return (recv env ncx psloc)
  (debug "normexp_return recv=" recv "\n ncx=" ncx)
  (assert_msg "check return recv" (is_a recv class_source_return) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (or (get_field :loca_location recv) psloc))
         (srets (unsafe_get_field :sargop_args recv))
         (:long nbrets (multiple_length srets))
         (csym (clone_symbol 'return_))
         (curproc (get_field :nctx_curproc ncx))
         (restype (cond ( (is_a curproc class_nrep_routproc)
                          ctype_value)
                        ( (is_a curproc class_nrep_hookproc)
                          (get_field :nrhook_ctype curproc))
                        ( :else
                          (error_at sloc 
                                    "RETURN outside of LAMBDA or DEFUN procedure or DEFHOOK")
                          (return))))
         ;; while the return effectively go out, it is preferable to give it a value type
         ;; to avoid make warning on code like (if (p x) (return) (.....))
         (cbind (instance class_normal_let_binding
                          :letbind_loc sloc
                          :binder csym
                          :letbind_type restype 
                          ;; :letbind_expr is filled later
                          ))
         (clocc (instance class_nrep_locsymocc
                          :nrep_loc sloc
                          :nocc_ctyp restype
                          :nocc_symb csym
                          :nocc_bind cbind)) 
         )
    (debug "normexp_return srets=" srets " curproc=" curproc)
    ;; special case for empty return
    (if (<=i nbrets 0)
        (let ( 
              (nbindemp (make_list discr_list))
              (nemptret 
               (instance class_nrep_return
                         :nrep_loc sloc
                         :nret_main ()
                         :nret_rest ()
                         ))
              )
          (unsafe_put_fields cbind :letbind_expr nemptret)
          (list_append nbindemp cbind)
          (debug "normexp_return empty; return clocc=" clocc " nbindemp=" nbindemp)
          (return clocc nbindemp))
      (multicall
       (nrets nbindrets)
       (normalize_tuple srets env ncx sloc)
       (debug "normexp_return nrets=" nrets " nbindrets=" nbindrets)
       (when (and
              (>i nbrets 1)
              (is_a curproc class_nrep_hookproc))
         (error_at sloc
                   "multiple RETURN not allowed inside hooks")
         (return))
       (let ( (nret0 (multiple_nth nrets 0))
              (toth (make_multiple discr_multiple (-i nbrets 1))) 
              (ctyp0 (get_ctype nret0 env))
              )
         (when 
             (and 
              (!= ctyp0 ctype_value)
              (is_a curproc class_nrep_routproc))
           (error_at sloc 
                        "primary RETURN-ed result from procedure is not a value")
           (return))
         (when (is_a curproc class_nrep_hookproc)
           (when (>i nbrets 1)
             (error_at sloc "RETURN with secondary results impossible in a hook")
             (return))
           (when (and nret0 ctyp0 (!= ctyp0 restype))
             (error_at sloc "RETURN with incompatible type in hook expected type $1 gotten $2"_ 
                       (get_field :named_name restype)
                       (get_field :named_name ctyp0))
             (return))
           )
         (if (null nbindrets) 
             (setq nbindrets (make_list discr_list)))
         ;; add a void binding to check interrupts
         (let ( (rintsymb (clone_symbol '_retint_))
                (nchint (instance class_nrep_checksignal
                                  :nrep_loc sloc))
                (rintbind (instance class_normal_let_binding
                                    :binder rintsymb
                                    :letbind_type ctype_void
                                    :letbind_expr nchint
                                    ))
                )
           (list_append nbindrets rintbind)
           )
         ;;
         (foreach_in_multiple
          (nrets)
          (ncomp :long ix)
          (let ( (nctyp (get_ctype ncomp env))
                 )
            (assert_msg "check nctyp" (is_a nctyp class_ctype) nctyp)
            (unless (get_field :ctype_parchar nctyp)
              (error_at sloc "impossible secondary result type $1"_
                        (get_field :named_name nctyp)))
            )
          (if (>i ix 0)
              (multiple_put_nth toth (-i ix 1) ncomp)))
;;;
         (let ( (nret
                 (instance class_nrep_return
                           :nrep_loc sloc
                           :nret_main nret0
                           :nret_rest (if (>i nbrets 0) toth)))
                )
           (unsafe_put_fields cbind :letbind_expr nret)
           (list_append nbindrets cbind)
           (debug "normexp_return result clocc=" clocc " nbindrets=" nbindrets)
           (return clocc nbindrets)
           ))))))
(install_method class_source_return normal_exp normexp_return)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; normalize an if
(defun normexp_if (recv env ncx psloc)
  (assert_msg "check if recv" (is_a recv class_source_if) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (debug "normexp_if recv" recv)
  (let ( (sloc (unsafe_get_field :loca_location recv))
         (stest (unsafe_get_field :sif_test recv))
         (ctypif ctype_void)
         (sthen (unsafe_get_field :sif_then recv))
         (cintsymb (clone_symbol '_if_inter_))
         (nchint (instance class_nrep_checksignal
                           :nrep_loc sloc))
         (cintbind (instance class_normal_let_binding
                             :binder cintsymb
                             :letbind_type ctype_void
                             :letbind_expr nchint))
         )
    (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) nbindif)
     (debug "normexp_if ntest=" ntest " cintbind=" cintbind)
     ;; prepend the check interrupt binding
     (if (null nbindif) 
         (setq nbindif (list cintbind))
       (list_prepend nbindif cintbind))
     ;;
     ;; 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)
      (debug "normexp_if nthen" nthen)
      (assert_msg "check nbindthen" (is_list_or_null nbindthen) nbindthen)
      (let ( (newthenenv (fresh_env env)) )
        (list_every 
         nbindthen
         (lambda (b) (put_env newthenenv b)))
        ;; the ctyp of the whole if is initialized to the ctype of the then part
        (setq ctypif (get_ctype nthen newthenenv))
        ;;
        (let ( (csym (clone_symbol '_if_))
               (clocc  (instance  class_nrep_locsymocc
                                  :nrep_loc sloc
                                  :nocc_ctyp ctypif
                                  :nocc_symb csym)) 
               (wthen (wrap_normal_let1 nthen nbindthen sloc))
               (cbind (instance class_normal_let_binding
                                :letbind_loc sloc
                                :binder csym
                                :letbind_type ctypif 
                                :letbind_expr 
                                (instance class_nrep_if
                                          :nrep_loc sloc
                                          :nif_test ntest
                                          :nif_then wthen
                                          :nif_else ()
                                          :nexpr_ctyp ctypif
                                          ))) 
               )
          (unsafe_put_fields clocc :nocc_bind cbind)
          (if (not (is_list nbindif))
              (setq nbindif (make_list discr_list)))
          (list_append nbindif cbind)
          (debug "normexp_if result clocc=" clocc " nbindif=" nbindif)
          (return clocc nbindif)
          ))
      ))))
(install_method class_source_if normal_exp normexp_if)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; normalize an ifelse
(defun normexp_ifelse (recv env ncx psloc)
  (debug "normexp_ifelse recv=" recv "\n.. env=" debug_more env 
         "\n.. of prec=" debug_less (get_field :env_prev env) "\n")
  (assert_msg "check if recv" (is_a recv class_source_ifelse) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (unsafe_get_field :loca_location 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 "normexp_ifelse sloc=" debug_less sloc "; stest=" stest)
    (multicall 
     (ntest nbindif)         ;nbindif is also the whole result binding
     (normal_exp stest env ncx sloc)
     (debug "normexp_ifelse ntest=" ntest "; nbindif=" nbindif)
     (assert_msg "check nbindif test" (is_list_or_null nbindif) nbindif)
     ;; prepend interrupt check void binding
     (let ( (cintsymb (clone_symbol '_ifelse_inter_))
            (nchint (instance class_nrep_checksignal
                              :nrep_loc sloc))
            (cintbind (instance class_normal_let_binding
                                :binder cintsymb
                                :letbind_type ctype_void
                                :letbind_expr nchint))
           )
       (if (is_list nbindif)
           (list_prepend nbindif cintbind)
         (setq nbindif (list cintbind))))
     ;; 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
     (debug "normexp_ifelse sloc=" debug_less sloc "; sthen=" sthen)
     (multicall 
      (nthen nbindthen)
      (normal_exp sthen env ncx sloc)
      (debug "normexp_ifelse nthen=" nthen " nbindthen=" nbindthen)
      (assert_msg "check nbindthen" (is_list_or_null nbindthen) nbindthen)
      (let ( (newthenenv (fresh_env env)) )
        (debug "normexp_ifelse sloc=" debug_less sloc "; newthenenv=" newthenenv)
        (list_every 
         nbindthen
         (lambda (b) (put_env newthenenv b)))
        ;; the ctyp of the whole if is initialized to the ctype of the then part
        (setq ctypif (get_ctype nthen newthenenv))
        (debug "normexp_ifelse sloc=" debug_less sloc "; selse=" selse)
        (multicall 
         (nelse nbindelse)
         (normal_exp selse env ncx sloc)
         (debug "normexp_ifelse nelse=" nelse " nbindelse=" nbindelse)
         (assert_msg "check nbindelse" (is_list_or_null nbindelse) nbindelse)
         ;; if we have both then & else branches,
         ;; ensure their compatibility of types
         (let ( (newelseenv (let ( (nenv (fresh_env env)) )
                              (list_every 
                               nbindelse
                               (lambda (b) (put_env nenv b)))
                              nenv
                              ))
                (ctypelse (get_ctype nelse newelseenv)) 
                )
           (debug "normexp_ifelse sloc=" debug_less sloc " newelseenv=" newelseenv)
           (assert_msg "check ctypif" (is_a ctypif class_ctype) ctypif)
           (assert_msg "check ctypelse" (is_a ctypelse class_ctype) ctypelse)
           (cond
            ( (== ctypif ctypelse)
              ()
              )
            ( (and (!= ctypif ctype_void) (== ctypelse ctype_void))
              () ;; ctypif is correct
              )
            ( (and (== ctypif ctype_void) (!= ctypelse ctype_void))
              (setq ctypif ctypelse)
              )
            (:else
             (error_at sloc 
                            "incompatible types in conditional IF/OR/COND branches: then type is $1 else type is $2"_ 
                            (unsafe_get_field :named_name ctypif)
                            (unsafe_get_field :named_name ctypelse))
             (setq ctypif ctype_void)
             )
            ))
         ;;
         ;;
         (let ( (csym (clone_symbol '_ifelse_))
                (clocc  (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 (instance class_normal_let_binding
                                 :letbind_loc sloc
                                 :binder csym
                                 :letbind_type ctypif 
                                 :letbind_expr 
                                 (instance class_nrep_if
                                           :nrep_loc sloc
                                           :nif_test ntest
                                           :nif_then wthen
                                           :nif_else welse
                                           :nexpr_ctyp ctypif
                                           ))) )
           (unsafe_put_fields clocc :nocc_bind cbind)
           (if (not (is_list nbindif))
               (setq nbindif (make_list discr_list)))
           (list_append nbindif cbind)
           (debug "normexp_ifelse result clocc=" clocc " nbindif=" nbindif)
           (return clocc nbindif)
           )))))))
(install_method class_source_ifelse normal_exp normexp_ifelse)



;;;;;;;;;;;;;;;; normalize a cppif
(defun normexp_cppif (recv env ncx psloc)
  (assert_msg "check cppif recv" (is_a recv class_source_cppif) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (debug "normexp_cppif recv" recv)
  (let ( (sloc (unsafe_get_field :loca_location recv))
         (scond (unsafe_get_field :sifp_cond recv))
         (ctypif ctype_void)
         (sthen (unsafe_get_field :sifp_then recv))
         (selse (unsafe_get_field :sifp_else recv))
         )
    ;; normalize the then-part
    (multicall 
     (nthen nbindthen)
     (normal_exp sthen env ncx sloc)
     (debug "normexp_cppif nthen" nthen)
     (assert_msg "check nbindthen" (is_list_or_null nbindthen) nbindthen)
     (let ( (newthenenv (fresh_env env)) )
       (list_every 
        nbindthen
        (lambda (b) (put_env newthenenv b)))
       ;; the ctyp of the whole cppif is initialized to the ctype of the then part
       (setq ctypif (get_ctype nthen newthenenv))
       (assert_msg "check ctypif" (is_a ctypif class_ctype) ctypif)
       ;; normalize the else-part
       (multicall 
        (nelse nbindelse)
        (normal_exp selse env ncx sloc)
        (debug "normexp_cppif nelse" nelse)
        (assert_msg "check nbindelse" (is_list_or_null nbindelse) nbindelse)
        (let ( (newelseenv (fresh_env env)) )
          (foreach_pair_component_in_list 
           (nbindelse)
           (curpairelse elsebind) 
           (put_env newelseenv elsebind))
          (let ( (ctypelse (get_ctype nelse newelseenv)) )
            (when (and (!= ctypif ctypelse) (!= ctypif ctype_void) (!= ctypelse ctype_void))
              (error_at sloc "CPPIF incompatible then $1 & else $2 types"_
                        (unsafe_get_field :named_name ctypif)
                        (unsafe_get_field :named_name ctypelse))
              ))

          (let ( (csym (clone_symbol 'ifcpp_))
                 (clocc  (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 (instance class_normal_let_binding
                                  :letbind_loc sloc
                                  :binder csym
                                  :letbind_type ctypif 
                                  :letbind_expr 
                                  (instance class_nrep_cppif
                                            :nrep_loc sloc
                                            :nifp_cond scond
                                            :nifp_then wthen
                                            :nifp_else welse
                                            :nifp_ctyp ctypif
                                            ))) 
                 (nbindres (make_list discr_list))
                 )
            (unsafe_put_fields clocc :nocc_bind cbind)
            (list_append nbindres cbind)
            (debug "normexp_cppif result clocc=" clocc " nbindres=" nbindres)
            (return clocc nbindres)
            )))))))
(install_method class_source_cppif normal_exp normexp_cppif)

;;;;;;;;;;;;;;;; normalize an or
;; (OR (f1 a1)) is let d1 = (f1 a1) in d1
;; (OR (f1 a1) (f2 a2)) is let o1 = (let d1 = (f1 a1) in  (if d1 d1 (let d2 = (f2 a2) in d2))) in o1
(defun normexp_or (recv env ncx psloc)
  (assert_msg "check or recv" (is_a recv class_source_or) recv)
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug "normexp_or recv" recv)
  (let ( 
        (boxorcount (make_integerbox discr_integer (melt_callcount)))
        (sloc (unsafe_get_field :loca_location recv))
        (sdisj (unsafe_get_field :sor_disj recv))
        (:long nbdisj (multiple_length sdisj))
        (:long ix (-i nbdisj 1))
        (norcont (reference ()))
        (nbindorcont (reference (make_list discr_list)))
        (ctyporcont (reference ctype_void))
        (newenv (fresh_env env))
        )
    (multiple_backward_every 
     sdisj
     (lambda (scur :long six)
       (debug "normexp scur=" scur "call#" (get_int boxorcount))
       (multicall
        (ncur nbind)
        (normal_exp scur env ncx sloc)
        (debug "normexp ncur=" ncur " nbind=" nbind " call#" (get_int boxorcount))
        (list_every ncur
                    (lambda (bnd) (put_env newenv bnd)))
        (if (null (deref norcont))
            (progn
              (set_ref nbindorcont nbind)
              (set_ref norcont ncur) 
              (set_ref ctyporcont (get_ctype ncur newenv))
              ()
              )
          (let ( (ctypcur (get_ctype ncur newenv))
                 )
            (assert_msg "check ctypcur" (is_a ctypcur class_ctype))
            (if (!= ctypcur (deref ctyporcont))
                (error_at  sloc "disjuncts' type mismatch in OR | COND got $1 expecting $2"_ ctypcur (deref ctyporcont)))
            (let (
                  ;; ncur is normal, so simple
                  (nifor (instance
                          class_nrep_if
                          :nrep_loc sloc
                          :nif_test ncur
                          :nif_then ncur
                          :nif_else (wrap_normal_let1 (deref norcont) (deref nbindorcont) sloc)
                          :nexpr_ctyp ctypcur
                          )
                         )
                  (csymor (clone_symbol 'or_))
                  (corbind (instance 
                            class_normal_let_binding
                            :binder csymor
                            :letbind_loc sloc
                            :letbind_type ctypcur
                            :letbind_expr nifor))
                  (corocc (instance
                           class_nrep_locsymocc
                           :nrep_loc sloc
                           :nocc_ctyp ctypcur
                           :nocc_symb csymor
                           :nocc_bind corbind))
                  )
              (set_ref nbindorcont (make_list discr_list))
              (list_append2list (deref nbindorcont) nbind)
              (list_append (deref nbindorcont) corbind)
              (set_ref norcont corocc)
              ()
              )
            )
          )
        )
       )
     )
    (debug "normexp_or result nor=" !norcont " nbindor=" !nbindorcont)
    (return !norcont !nbindorcont)
    )
  )
(install_method class_source_or normal_exp normexp_or)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a PROGN
;;;; (PROGN a1 a2 ... an) is based upon the normalization of (LET () a1 a2 ... an)
(defun normexp_progn (recv env ncx psloc)
  (assert_msg "check progn recv" (is_a recv class_source_progn))
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug "normexp_progn recv" recv)
  (let ( (sloc (unsafe_get_field :loca_location recv))
         (sbody (unsafe_get_field :sprogn_body recv))
         (:long lnbody (multiple_length sbody)) 
         (boxlnbody (make_integerbox discr_integer lnbody))
         )
    (if (<=i lnbody 0)
        (let ( (onull (instance class_nrep_nil :nrep_loc sloc)) )
          (error_at sloc "empty PROGN")
          (debug "normexp_progn return empty onull" onull)
          (return onull)))
    (multicall
     (nbody nbind)
     (normalize_tuple sbody env ncx sloc)
     (debug "normexp_progn nbody=" nbody " nbind=" nbind)
     (let ( (nlast (multiple_nth nbody -1)) 
            (:long lenbody (multiple_length nbody))
            (nallbutlast (if (>i lenbody 0) (make_multiple discr_multiple (-i lenbody 1))))
            )
       ;; fill nallbutlast 
       (let ( (:long ix (-i lenbody 1)) )
         (forever bodyloop
                  (if (<i ix 0) (exit bodyloop))
                  (multiple_put_nth nallbutlast ix (multiple_nth nbody ix))
                  (setq ix (-i ix 1))))
       (debug "normexp_progn nallbutlast" nallbutlast)
       (if (null nbind) (setq nbind (make_list discr_list)))
       (let (
             (csym (clone_symbol 'progn_))
             (lastctyp (get_ctype nlast env))
             (cbind (instance class_normal_let_binding
                              :binder csym
                              :letbind_loc sloc
                              :letbind_type lastctyp
                              :letbind_expr (instance class_nrep_progn
                                                      :nrep_loc sloc
                                                      :nprogn_seq nallbutlast
                                                      :nprogn_last nlast)))
             (clocc (instance class_nrep_locsymocc
                              :nrep_loc sloc
                              :nocc_ctyp lastctyp
                              :nocc_symb csym
                              :nocc_bind cbind))
             )
         (list_append nbind cbind)
         (debug "normexp_progn return clocc=" clocc " nbind=" nbind)
         (return clocc nbind)
         )))))
(install_method class_source_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)
  (debug "normexp_let" " recv=" recv "\n.. env=" debug_more env
         "\n.. ncx=" ncx)
  (assert_msg "check let recv" (is_a recv class_source_let))
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (unsafe_get_field :loca_location recv))
         (sbindings (unsafe_get_field :slet_bindings recv))
         (sbody (unsafe_get_field :slet_body recv)) 
         (newenv (fresh_env env))
         (bindlist (make_list discr_list))
         )
    ;; loop on source bindings
    (foreach_in_multiple
     (sbindings)
     (sb :long sbix)
     (debug "normexp_let" " sloc=" sloc "; sbix#" sbix ";\n sb=" sb
            ";\n ncx=" debug_less ncx)
     (cond
      ;; handle the normal source let binding case
      (  (is_a sb class_source_let_binding)
         (let ( (sbloc (unsafe_get_field :loca_location sb))
                (sbtyp (unsafe_get_field :sletb_type sb))
                (sbinder (unsafe_get_field :sletb_binder sb))
                (sbexpr (unsafe_get_field :sletb_expr sb)) 
                )
           (assert_msg "check sbtyp" (is_a sbtyp class_quasi_ctype) sbtyp)
           ;; issue an inform message if the let binding overrides a previous one
           (and
            (has_extra_warnings)
            (find_env env sbinder)
            (inform_strv sbloc "this LET binding hides another one in enclosing scope - "
                         (get_field :named_name  sbinder))
            )
           ;; normalize the binding's expression
           (multicall
            (nbdexpr nbindings)
            (normal_exp sbexpr newenv ncx sbloc)
            ;;
            (debug "normexp_let" " nbdexpr=" nbdexpr " nbindings=" nbindings)
            ;; check that the ctype of the normalized expression
            ;; is the same as the let binding's ctype
            (let ( (nbctype (get_ctype nbdexpr newenv)) 
                   )
              (assert_msg "check nbctype" (is_a nbctype class_ctype) nbctype)
              ;; replace an :auto binding with the appropriate ctype
              ;; but reject a void ctype
              (when (== sbtyp quasi_ctype_auto)
                (if (== sbtyp ctype_void)
                    (error_at sbloc "auto LET binding of $1 should not be void"
                              sbinder))
                (setq sbtyp nbctype))
              ;; check ctype compatibility
              (when (!= nbctype sbtyp)
                (error_at 
                 sbloc
                 "ctype mismatch in LET binding of local variable $1 got $2 expecting $3"
                 (get_field :named_name  sbinder)
                 (get_field :named_name nbctype)
                 (get_field :named_name sbtyp))
                ))
            ;;
            (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_normal_let_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_every
                     nbindings
                     (lambda (b)
                       (if (!= b lastnbinding)
                           (list_append bindlist b))))
                    (let ( (newcbnd
                            (instance class_normal_let_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)
                      )
                    )
                (progn
                  ;; otherwise, eg a plain constant, a complex if...
                  (list_append2list bindlist  nbindings)
                  (let ( (newpbnd 
                          (instance class_normal_let_binding
                                    :binder sbinder
                                    :letbind_type sbtyp
                                    :letbind_expr nbdexpr
                                    :letbind_loc sbloc)) )
                    (list_append bindlist newpbnd)
                    (put_env newenv newpbnd)
                    ))
                ))))
         )
      ;; handle the local :macro binding case, this is happening after macro expansion
      ((is_a sb class_source_macro_let_binding)
       (debug "normexp_let" " sloc=" sloc ";\n.. macrobinding sb=" sb)
       (let ( (macsymb (get_field :sletb_binder sb))
              (mloc (or (get_field :loca_location sb) sloc))
              (mformals (get_field :sletm_macro_formals sb))
              (mbody (get_field :sletm_macro_body sb))
              (newmacenv (fresh_env newenv))
              (slambda (instance class_source_lambda_for_macro
                                 :loca_location mloc
                                 :slam_argbind mformals
                                 :slam_body mbody
                                 :slam_origmacro sb
                                 ))
              )
         (debug "normexp_let:macro" " before normalize_lambda sloc=" sloc "; slambda=" slambda
                "\n.. old ncx=" ncx
                "\n.. env=" debug_more env
                "\n.. newenv=" debug_more newenv
                "\n.. newmacenv=" debug_more newmacenv)
         (multicall 
          (manproc macsym maclocc maconstrout maclovtup masloc maoldproc mandatarout :long mainsideflag)
          (normalize_lambda slambda  newenv newmacenv ncx psloc)
          (debug "normexp_let:macro" " after normalize_lambda manproc=" manproc "\n.. macsym=" macsym 
                 "\n.. maclocc=" maclocc "\n.. maconstrout=" maconstrout "\n.. maclovtup=" maclovtup
                 "\n.. masloc=" masloc "\n.. maoldproc=" maoldproc "\n.. mandatarout=" mandatarout
                 "\n.. mainsideflag=" mainsideflag
                 "\n.. newenv=" debug_more newenv
                 "\n.. newmacenv=" debug_more newmacenv
                 "\n.. ncx=" ncx)
          (let (
                (maloc (or masloc mloc))
                (maclambda (instance class_nrep_macrolambda
                                     :nrep_loc maloc
                                     :nlambda_proc manproc
                                     :nlambda_constrout maconstrout
                                     :nlambda_closedv maclovtup))
                (macbind (instance class_normal_let_binding
                                   :letbind_loc maloc
                                   :binder macsymb
                                   :letbind_type ctype_value
                                   :letbind_expr maclambda))
                )
            (debug "normexp_let:macro" " maclambda=" maclambda)
            (put_fields maclocc :nocc_bind macbind)
            (debug "normexp_let:macro" " updated maclocc=" maclocc)
            (list_append bindlist macbind)
            (debug "normexp_let:macro" " updated bindlist=" bindlist)
            (put_env newenv macbind)
            (debug "normexp_let:macro" " updated newenv=" debug_more newenv "\n.. mainsideflag=" mainsideflag)
            (when mainsideflag
              (list_append (get_field :nrclop_constlist maoldproc) mandatarout)
              (debug "normexp_let:macro" " updated constlist in maoldproc=" maoldproc)
              )
            ))))
      ;;
      ;; impossible binding
      (:else
       (error_at sloc "impossible LET binding #$1" sbix)
       (assert_msg "impossible let binding" () sb sbix)
       (return))
      )
     )
    ;; end of loop on source bindings
    ;;
    (debug "normexp_let" " before normabody sloc=" sloc "; bindlist=" bindlist
           "\n.. sbody=" sbody
           "\n.. newenv=" debug_more newenv)
    (shortbacktrace_dbg "normexp_let before-normalizing-sbody" 15)
    (debug "normexp_let" " before normabody sloc=" sloc "\n.. ncx=" debug_less ncx
           "\n.. newenv=" debug_more newenv
           "\n.. env=" env)
    (multicall
     (nbody nbodbindings)
     (normalize_tuple sbody newenv ncx sloc)
     (debug "normexp_let"  " after normabody sloc=" sloc "; nbody=" nbody 
            "\n.. nbodbindings=" nbodbindings
            "\n.. old bindlist=" bindlist)
     (list_append2list bindlist nbodbindings)
     (debug "normexp_let"  " after normabody sloc=" sloc 
            "; updated bindlist=" bindlist)
     (assert_msg "normexp_let check bindlist" (is_list_or_null bindlist) bindlist)
     (foreach_pair_component_in_list
      (bindlist)
      (curpair cbnd) 
      (assert_msg "normexp_let check cbnd" (is_a cbnd class_normal_let_binding) cbnd))
     ;; remove every locally bound symbol from the symbol cache map
     (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx)) )
       (foreach_pair_component_in_list 
        (bindlist)
        (curpair bnd)
        (mapobject_remove sycmap (unsafe_get_field :binder bnd))
        )
       (debug "normexp_let shrinked updated sycmap=" sycmap)
       )
     ;; make the result
     (let (
           (nlastbody (multiple_nth nbody -1))
           ;; the type of a let with empty body is void
           (nlastyp (or (get_ctype nlastbody newenv) ctype_void))
           (csym (clone_symbol 'let_))
           (nlet
            (instance class_nrep_let
                      :nrep_loc sloc
                      :nlet_bindings (list_to_multiple bindlist discr_multiple)
                      :nlet_body nbody))
           (cbind (instance class_normal_let_binding
                            :binder csym
                            :letbind_loc sloc
                            :letbind_type nlastyp
                            :letbind_expr nlet))
           (clocc (instance class_nrep_locsymocc
                            :nrep_loc sloc
                            :nocc_ctyp nlastyp
                            :nocc_bind cbind))
           (resbinds (make_list discr_list))
           )
       (list_append resbinds cbind)
       (debug "normexp_let result clocc=" clocc " resbinds=" resbinds)
       (return clocc resbinds)
       )
     )))
;;;;
(install_method class_source_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)
  (debug "normexp unsafeget recv=" recv)
  (assert_msg "check unsafegetfield recv" (is_a recv class_source_unsafe_get_field) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc   (unsafe_get_field :loca_location recv))
         (sobj   (unsafe_get_field :suget_obj recv))
         (sfld   (unsafe_get_field :suget_field recv)) 
         ) 
    (assert_msg "check sfld" (is_a sfld class_field) sfld)
    (multicall
     (nobj nbind)
     (normal_exp sobj env ncx sloc)
     (if (null nbind) (setq nbind (make_list discr_list)))
     (let ( (csym (clone_symbol (unsafe_get_field :named_name sfld)))
            (cbind (instance class_normal_let_binding
                             :binder csym
                             :letbind_loc sloc
                             :letbind_type ctype_value
                             :letbind_expr 
                             (instance class_nrep_unsafe_get_field
                                       :nrep_loc sloc
                                       :nuget_obj nobj
                                       :nuget_field sfld)))
            (clocc (instance  class_nrep_locsymocc
                              :nrep_loc sloc
                              :nocc_ctyp ctype_value
                              :nocc_symb csym
                              :nocc_bind cbind))
            )
       (list_append nbind cbind)
       (debug "normexp unsafeget result clocc=" clocc " nbind=" nbind)
       (return  clocc nbind)))))
(install_method class_source_unsafe_get_field normal_exp normexp_unsafe_get_field)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; normalize an GET_FIELD
(defun normexp_get_field (recv env ncx psloc)
  (assert_msg "check getfield recv" (is_a recv class_source_get_field) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (debug "normexp_get_field recv" recv)
  (let ( (sloc   (unsafe_get_field :loca_location recv))
         (sobj   (unsafe_get_field :suget_obj recv))
         (sfld   (unsafe_get_field :suget_field recv)) 
         ) 
    (assert_msg "check sfld" (is_a sfld class_field) sfld)
    (multicall
     (nobj nbind)
     (normal_exp sobj env ncx sloc)
     (if (null nbind) (setq nbind (make_list discr_list)))
     (debug "normexp_get_field nobj" nobj)
     (let ( (csym (clone_symbol (unsafe_get_field :named_name sfld)))
            (fcla (unsafe_get_field :fld_ownclass sfld))
            (ncla (let ( (nc (normal_exp fcla env ncx psloc)) )
                    (debug "normexp_get_field ncla" nc)
                    nc))
            (nuget (instance class_nrep_unsafe_get_field
                             :nrep_loc sloc
                             :nuget_obj nobj
                             :nuget_field sfld))
            (cbind (instance class_normal_let_binding
                             :binder csym
                             :letbind_loc sloc
                             :letbind_type ctype_value
                             :letbind_expr 
                             (instance class_nrep_ifisa
                                       :nrep_loc sloc
                                       :nif_testval nobj
                                       :nifa_class ncla
                                       :nif_then nuget
                                       :nexpr_ctyp ctype_value
                                       )))
            (clocc (instance  class_nrep_locsymocc
                              :nrep_loc sloc
                              :nocc_ctyp ctype_value
                              :nocc_symb csym
                              :nocc_bind cbind))
            )
       (list_append nbind cbind)
       (debug "normexp_get_field clocc=" clocc " nbind=" nbind)
       (return  clocc nbind)))))
(install_method class_source_get_field normal_exp normexp_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_source_unsafe_put_fields) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (debug "normexp_unsafe_put_fields recv" recv)
  (let ( (sloc   (unsafe_get_field :loca_location recv))
         (sobj   (unsafe_get_field :suput_obj recv))
         (sfields (unsafe_get_field :suput_fields recv))
         (:long nbfields (multiple_length sfields))
         (nfields (make_multiple discr_multiple nbfields))
         (csym (clone_symbol 'unsafput_)) 
         (cintsymb (clone_symbol 'unsafput_inter_))
         (nchint (instance class_nrep_checksignal
                              :nrep_loc sloc))
         (cintbind (instance class_normal_let_binding
                             :binder cintsymb
                             :letbind_type ctype_void
                             :letbind_expr nchint))
         (nbindlist (list cintbind)) 
         (cbind (instance class_normal_let_binding
                          :binder csym
                          :letbind_loc sloc
                          :letbind_type ctype_void
                          ;; letbind_expr filled later
                          :letbind_expr ()))
         (clocc (instance  class_nrep_locsymocc
                           :nrep_loc sloc
                           :nocc_ctyp ctype_void
                           :nocc_symb csym
                           :nocc_bind cbind))
         )
    (multicall
     (nobj nobjbind)
     (normal_exp sobj env ncx sloc)
     (list_append2list nbindlist nobjbind)
     (multiple_every 
      sfields
      (lambda (fla :long ix) 
        (assert_msg "check fla" (is_a fla class_source_fieldassign) fla)
        (let ( (fld (unsafe_get_field :sfla_field fla))
               (exp (unsafe_get_field :sfla_expr fla)) 
               (fsloc (or (unsafe_get_field :loca_location fla) sloc))
               )
          (assert_msg "check fld" (is_a fld class_field) fld)
          (multicall
           (nexp nexpbind)
           (normal_exp exp env ncx sloc)
           (list_append2list nbindlist  nexpbind)
           (let ( (nfla (instance class_nrep_fieldassign
                                  :nrep_loc sloc
                                  :nfla_field fld
                                  :nfla_val nexp)) )
             (multiple_put_nth nfields ix nfla)
             (let ( (fctyp (get_ctype nexp env)) )
               (debug "normexp_unsafe_put_fields fctyp" fctyp)
               (if (!= fctyp ctype_value)
                   (error_at 
                    fsloc 
                    "invalid field type $1 in (UNSAFE_PUT_FIELDS ..); expecting a :value"_
                    (get_field :named_name fld))))
             )))))
     (let ( (npuf (instance class_nrep_unsafe_put_fields
                            :nrep_loc sloc
                            :nuput_obj nobj
                            :nuput_fields nfields)) )
       (unsafe_put_fields cbind :letbind_expr npuf)
       (list_append nbindlist cbind)
       (debug "normexp_unsafe_put_fields result clocc=" clocc
              " nbindlist=" nbindlist)
       (return clocc nbindlist)
       ))))
(install_method class_source_unsafe_put_fields normal_exp normexp_unsafe_put_fields)
(install_method class_nrep_unsafe_put_fields get_ctype (lambda (recv env) ctype_void))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; normalize an PUT_FIELDS
(defun normexp_put_fields (recv env ncx psloc)
  (assert_msg "check putfields recv" (is_a recv class_source_put_fields) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (debug "normexp_put_fields recv" recv)
  (let ( (sloc   (unsafe_get_field :loca_location recv))
         (sobj   (unsafe_get_field :suput_obj recv))
         (sfields (unsafe_get_field :suput_fields recv))
         (:long nbfields (multiple_length sfields))
         (nfields (make_multiple discr_multiple nbfields))
         (csym (clone_symbol 'putfld_))
         (cintsymb (clone_symbol 'putfld_inter_))
         (nchint (instance class_nrep_checksignal
                              :nrep_loc sloc))
         (cintbind (instance class_normal_let_binding
                             :binder cintsymb
                             :letbind_type ctype_void
                             :letbind_expr nchint))
         (nbindlist (list cintbind)) 
         (cbind (instance class_normal_let_binding
                          :binder csym
                          :letbind_loc sloc
                          :letbind_type ctype_void
                          ;; letbind_expr filled later
                          :letbind_expr ()))
         (clocc (instance  class_nrep_locsymocc
                           :nrep_loc sloc
                           :nocc_ctyp ctype_void
                           :nocc_symb csym
                           :nocc_bind cbind))
         (clacont (reference ()))
         )
    (multicall
     (nobj nobjbind)
     (normal_exp sobj env ncx sloc)
     (list_append2list nbindlist  nobjbind)
     (foreach_in_multiple 
      (sfields)
      (fla :long ix) 
      (debug "normexp_put_fields fla=" fla " clacont=" clacont)
      (assert_msg "check fla" (is_a fla class_source_fieldassign) fla)
      (let ( (fld (unsafe_get_field :sfla_field fla))
             (exp (unsafe_get_field :sfla_expr fla)) 
             (fsloc (or (unsafe_get_field :loca_location fla) sloc))
             )
        (assert_msg "check fld" (is_a fld class_field) fld)
        (let ( (fcla (unsafe_get_field :fld_ownclass fld)) 
               (precla (deref clacont))
               )
          (cond ( (null precla)
                  (set_ref clacont fcla)
                  )
                ( (== precla fcla)
                  ()
                  )
                ( (subclass_of precla fcla)
                  ()
                  )
                ( (subclass_of fcla precla)
                  (set_ref clacont fcla)
                  )
                (:else
                 (debug "normexp_put_fields bad fld=" fld " fcla=" fcla
                        " precla=" precla)
                 (error_at sloc 
                           "bad field name $1 in PUT_FIELD should be a field from class $1 but got field from $3"_ 
                           (get_field :named_name fld)
                           (get_field :named_name precla)
                           (get_field :named_name fcla))
                 )
                )
          )
        (multicall
         (nexp nexpbind)
         (normal_exp exp env ncx sloc)
         (list_append2list nbindlist  nexpbind)
         (let ( (nfla (instance class_nrep_fieldassign
                                :nrep_loc sloc
                                :nfla_field fld
                                :nfla_val nexp)) )
           (let ( (fctyp (get_ctype nexp env)) 
                  )
             (if (!= fctyp ctype_value)
                   (error_at 
                    fsloc 
                    "invalid field $1 actual type $2 in (PUT_FIELDS ..); expecting a :value"_
                    (get_field :named_name fld)
                    (get_field :named_name fctyp))
                 )
             )
           (multiple_put_nth nfields ix nfla)
           ))))
     (let (
           (ncla (normal_exp (deref clacont) env ncx sloc))
           (npuf (instance class_nrep_unsafe_put_fields
                           :nrep_loc sloc
                           :nuput_obj nobj
                           :nuput_fields nfields)) 
           (nif (instance class_nrep_ifisa
                          :nrep_loc sloc
                          :nif_testval nobj
                          :nifa_class ncla
                          :nif_then npuf
                          :nexpr_ctyp ctype_void
                          )
                ))
       (unsafe_put_fields cbind :letbind_expr nif)
       (list_append nbindlist cbind)
       (debug "normexp_put_fields result clocc=" clocc " nbindlist=" nbindlist)
       (return clocc nbindlist)
       ))))
(install_method class_source_put_fields normal_exp normexp_put_fields)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; normalize a setq
(defun normexp_setq (recv env ncx psloc)
  (debug "normexp setq recv=" recv)
  (assert_msg "check setq recv" (is_a recv class_source_setq) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc   (unsafe_get_field :loca_location recv))
         (svar   (unsafe_get_field :sstq_var recv))
         (sexp   (unsafe_get_field :sstq_expr recv)) ) 
    (assert_msg "check svar" (is_a svar class_symbol) svar)
    (let ( (nvar (normexp_symbol svar env ncx sloc)) 
           (varctyp (get_ctype nvar env))
           )
      (debug "normexp_setq varctyp" varctyp)
      (assert_msg "check varctyp" (is_a varctyp class_ctype) varctyp)
      (multicall
       (nexp nbind)
       (normal_exp sexp env ncx sloc)
       (if (null nbind) (setq nbind (make_list discr_list)))
       (let ( (expctyp (get_ctype nexp env))
              )
         (debug "normexp_setq expctyp=" expctyp)
         (assert_msg "check expctyp" (is_a expctyp class_ctype) expctyp)
         (when (!= varctyp expctyp)
               (error_at sloc "incompatible type for SETQ of $1 left ctype is $2 right is $3"_
                         (unsafe_get_field :named_name svar)
                         (unsafe_get_field :named_name varctyp)
                         (unsafe_get_field :named_name expctyp))
               ))
       (when (is_a nvar class_nrep_modulevarocc)
         (debug "normexp_setq modulevarocc nexp=" nexp " nvar=" nvar)
         (let ( (csym (clone_symbol 'putstatic_))
                (csbind (instance class_normal_let_binding
                                 :binder csym
                                 :letbind_loc sloc
                                 :letbind_type ctype_void
                                 :letbind_expr
                                 (instance class_nrep_putmodulevar
                                           :nrep_loc sloc
                                           :nputmod_destvar nvar
                                           :nputmod_value nexp)))
                (cslocc (instance class_nrep_locsymocc
                                 :nrep_loc sloc
                                 :nocc_ctyp ctype_void
                                 :nocc_symb csym
                                 :nocc_bind csbind)
                        )
                )
           (debug "normexp_set static csbind=" csbind "\n cslocc=" cslocc)
           (list_append nbind csbind)
           (return cslocc nbind)
         ))
       ;;
       (let ( (csym (clone_symbol 'setq_)) 
              (cbind  (instance class_normal_let_binding
                                :binder csym
                                :letbind_loc sloc
                                :letbind_type varctyp
                                :letbind_expr
                                (instance class_nrep_setq
                                          :nrep_loc sloc
                                          :nstq_var nvar
                                          :nstq_exp nexp)))
              (clocc (instance class_nrep_locsymocc
                               :nrep_loc sloc
                               :nocc_ctyp varctyp
                               :nocc_symb csym
                               :nocc_bind cbind))
              )
         (list_append nbind cbind)
         (return clocc nbind)
         )))))
(install_method class_source_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 instance
(defun normexp_instance (recv env ncx psloc)
  (assert_msg "check instance recv" (is_a recv class_source_instance) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (debug "normexp_instance recv=" recv)
  (let ( (sloc (unsafe_get_field :loca_location 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)))
         (cintsymb (clone_symbol 'instance_inter_))
         (nchint (instance class_nrep_checksignal
                           :nrep_loc sloc))
         (cintbind (instance class_normal_let_binding
                             :binder cintsymb
                             :letbind_type ctype_void
                             :letbind_expr nchint))
         (bindlist (list cintbind))
         )
    ;; initial checks about class
    (cond 
     ( (is_not_a sclass class_class)
       (debug "normexp_instance bad sclass" sclass)
       (error_at sloc "bad class in (INSTANCE <class> [:field1 <expr1> ...]) expression")
       (return ())
       )
     ( (is_not_a cladata class_nrep)
       (debug "normexp_instance bad cladata" cladata)
       (error_at sloc "invalid class $1 in (INSTANCE <class> [:field1 <expr1> ...]) expression" 
                   (get_field :named_name sclass))
       (return ()))
     )
    ;; normalize the field assigments
    (let ( (nfields 
            (multiple_map 
             sfields 
             (lambda (curflda :long curk)
               (debug "normexp_instance.lambda curflda" curflda)
               (assert_msg "check curflda" (is_a curflda class_source_fieldassign) curflda)
               (let ( (curfloc (unsafe_get_field :loca_location curflda))
                      (curfield (unsafe_get_field :sfla_field curflda))
                      (curexp (unsafe_get_field :sfla_expr curflda)) )
                 (if (null curfloc) (setq curfloc sloc))
                 ;; check the curfield
                 (cond
                  ( (is_not_a curfield class_field)
                    (debug "normexp_instance corrupted curflda=" curflda
                           " curfield=" curfield)
                    (error_at sloc 
                              "invalid field #$1 in (INSTANCE $2 [:field1 <expr1> ...]) expression"
                              curk
                              (get_field :named_name sclass))
                    (return))
                  ( (not (subclass_or_eq sclass (unsafe_get_field :fld_ownclass curfield)))
                    (debug "normexp_instance corrupted curflda=" curflda
                           " curfield=" curfield)
                    (error_at sloc
                              "unexpected field $1 from class $2 in (INSTANCE $3 [:field1 <expr1> ...]) expression"_
                              (get_field :named_name curfield)
                              (get_field :named_name (get_field :fld_ownclass curfield))
                              (get_field :named_name sclass)
                              )
                    (return))
                  )
                 ;;
                 (multicall
                  (nexp nbind)
                  (normal_exp curexp env ncx curfloc)
                  (assert_msg "check nbind" (is_list_or_null nbind) nbind)
                  (let ( (fctyp (get_ctype nexp env)) )
                    (debug "normexp_instance fctyp" fctyp)
                    (if (!= fctyp ctype_value)
                        (error_at 
                         curfloc 
                         "invalid field $1 type $2 in (INSTANCE ..); expecting a :value"
                         (get_field :named_name curfield)
                         (get_field :named_name fctyp))))
                  (list_append2list bindlist  nbind)
                  (instance class_nrep_fieldassign
                            :nrep_loc curfloc
                            :nfla_field curfield
                            :nfla_val nexp)
                  )))))
           (nmkins 
            (instance class_nrep_instance
                      :nrep_loc sloc
                      :nmins_class sclass
                      :nmins_cladata cladata
                      :nmins_fields nfields))
           (csym (clone_symbol 'inst_))
           (cbind (instance class_normal_let_binding
                            :binder csym
                            :letbind_loc sloc
                            :letbind_type ctype_value
                            :letbind_expr nmkins))
           (clocc (instance class_nrep_locsymocc
                            :nrep_loc sloc
                            :nocc_ctyp ctype_value
                            :nocc_symb csym
                            :nocc_bind cbind))
           )
      (list_append bindlist cbind)
      (debug "normexp_instance result clocc=" clocc " bindlist=" bindlist)
      (return clocc bindlist)
      )
    )
  )
(install_method class_source_instance normal_exp normexp_instance)
(install_method class_source_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_source_forever) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (debug "normexp_forever recv=" recv)
  (let ( (sloc   (unsafe_get_field :loca_location 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) slbind)
    (put_env newenv slbind)
    (let ( (resy (clone_symbol (unsafe_get_field :binder slbind))) )
      (debug "normexp_forever putting resy=" resy " in slbind=" slbind)
      (unsafe_put_fields slbind :labind_clonsy resy)
      (debug "normexp_forever updated slbind" slbind)
      (assert_msg "check resy" (is_a resy class_cloned_symbol) resy)
      (debug "normexp_forever got1 clonsy "(unsafe_get_field :labind_clonsy slbind) )
      (assert_msg "check did1 put resy" (== (unsafe_get_field :labind_clonsy slbind) resy) resy slbind)
      (multicall
       (nbody nbodbindings)
       (normalize_tuple sbody newenv ncx sloc)
       (debug "normexp_forever again slbind=" slbind " nbody=" nbody " nbodbindings=" nbodbindings)
       ;; prepend an interrupt check binding
       (let ( (cintsymb (clone_symbol 'forever_inter_))
              (nchint (instance class_nrep_checksignal
                                :nrep_loc sloc))
              (cintbind (instance class_normal_let_binding
                                  :binder cintsymb
                                  :letbind_type ctype_void
                                  :letbind_expr nchint))
             )
         (if (null nbodbindings) 
             (setq nbodbindings (list cintbind))
           (list_prepend nbodbindings cintbind))
         )
       (assert_msg "check size slbind" (<i (get_int labind_clonsy) (object_length slbind)) labind_clonsy slbind)
       (let (
             (resbody (tuple 
                       (wrap_normal_letseq nbody nbodbindings sloc)))
             (csym (clone_symbol 'forever_))
             (nforever (instance class_nrep_forever
                                 :nrep_loc sloc
                                 :nforever_bind slbind
                                 :nforever_body resbody
                                 :nforever_result resy)) 
             (cbind (instance class_normal_let_binding
                              :binder csym
                              :letbind_loc sloc
                              :letbind_type ctype_value
                              :letbind_expr nforever))
             (clocc (instance class_nrep_locsymocc
                              :nrep_loc sloc
                              :nocc_ctyp ctype_value
                              :nocc_symb csym
                              :nocc_bind cbind))
             (nforbindings (make_list discr_list))
             )
         (list_append nforbindings cbind)
         (debug "normexp_forever return clocc=" clocc 
                " nforbindings=" nforbindings)
         (return clocc nforbindings)
         )
       ))))
(install_method class_source_forever normal_exp normexp_forever)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; normalize an exit
;;; the normalization of an exit is a local variable of ctype_void
;;; this enables detection of applications like (foo (exit looplab))
(defun normexp_exit (recv env ncx psloc)
  (assert_msg "check exit recv" (is_a recv class_source_exit) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (debug "normexp_exit recv" recv)
  (let ( (sloc   (unsafe_get_field :loca_location 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) slbind)
    (put_env newenv slbind)
    (multicall
     (nbody nbodbindings)
     (normalize_tuple sbody newenv ncx sloc)
     (if (null nbodbindings)
         (setq nbodbindings (make_list discr_list)))
     ;; the only interesting value of nbody is the last one
     (let ( (nexit (instance class_nrep_exit
                             :nrep_loc sloc
                             :nexit_bind slbind
                             :nexit_val (multiple_nth nbody (-i (multiple_length nbody) 1)))) 
            (csym (clone_symbol 'exit_))
            (cbind (instance class_normal_let_binding
                             :binder csym
                             :letbind_loc sloc
                             :letbind_type ctype_void
                             :letbind_expr nexit))
            (clocc (instance class_nrep_locsymocc
                             :nrep_loc sloc
                             :nocc_ctyp ctype_void
                             :nocc_symb csym
                             :nocc_bind cbind))
            )
       (list_append nbodbindings cbind)
       (debug "normexp_exit clocc=" clocc " nbodbindings=" nbodbindings)
       (return clocc nbodbindings)
       ))))
(install_method class_source_exit normal_exp normexp_exit)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize again
(defun normexp_again (recv env ncx psloc)
  (debug "normexp_again recv=" recv)
  (assert_msg "check again recv" (is_a recv class_source_again) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc   (unsafe_get_field :loca_location recv))
         (slbind (unsafe_get_field :slabel_bind recv))
         (csym (clone_symbol 'again_))
         (nagain (instance class_nrep_again
                           :nrep_loc sloc
                           :nagain_bind slbind))
         (cbind (instance class_normal_let_binding
                          :binder csym
                          :letbind_loc sloc
                          :letbind_type ctype_void
                          :letbind_expr nagain))
         (clocc (instance class_nrep_locsymocc
                          :nrep_loc sloc
                          :nocc_ctyp ctype_void
                          :nocc_symb csym
                          :nocc_bind cbind))     
         (nbindings (list cbind))
         )
    (assert_msg "check slbind" (is_a slbind class_label_binding) slbind)
    (debug "normexp_again clocc=" clocc " nbindings=" nbindings)
    (return clocc nbindings)    
    ))
(install_method class_source_again normal_exp normexp_again)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize ifvariadic
(defun normexp_ifvariadic (recv env ncx psloc)
  (debug "normexp_ifvariadic recv=" recv)
  (assert_msg "check ifvariadic recv" (is_a recv class_source_ifvariadic) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (loc (or (unsafe_get_field :loca_location recv) psloc))
         (sargs (unsafe_get_field :sifvariadic_argbind recv))
         (:long nbargs (multiple_length sargs))
         (sthen (unsafe_get_field :sifvariadic_then recv))
         (selse (unsafe_get_field :sifvariadic_else recv))
         (curpro (unsafe_get_field :nctx_curproc ncx))
         (sycmap (unsafe_get_field :nctx_symbcachemap ncx))
         (curprocargs (get_field :nrclop_argbindtuple curpro))
         (nprovariadic (get_field :nrpro_variadic curpro))
         (newenv (fresh_env env))
         )
    (debug "normexp_ifvariadic curpro=" curpro "\n.. sycmap=" sycmap "\n.. loc=" loc)
    (assert_msg "normexp_ifvariadic check sthen" (is_multiple_or_null sthen) sthen)
    (assert_msg "normexp_ifvariadic check selse" (is_multiple_or_null selse) selse)
    (when (is_not_a curprocargs discr_variadic_formal_sequence)
      (debug "normexp_ifvariadic bad curprocargs=" curprocargs " loc=" loc)
      (error_at loc "(VARIADIC ...) used in non-variadic function")
      (return))
    (debug "normexp_ifvariadic nprovariadic=" nprovariadic "; loc=" loc)
    (assert_msg "normexp_ifvariadic has nprovariadic" nprovariadic nprovariadic)
    ;; we transform the sequence of formal bindings into a sequence of
    ;; normal let bindings...
    (let ( (letbindtup (make_multiple discr_multiple nbargs))
           (letbindthenlist (make_list discr_list))
           (locsymtup (make_multiple discr_multiple nbargs))
           (ctyptup (make_multiple discr_multiple nbargs))
           )
      (foreach_in_multiple
       (sargs)
       (fbi :long fbix)
       (debug "normexp_ifvariadic fbi=" fbi)
       (assert_msg "check fbi" (is_a fbi class_formal_binding) fbi)
       (let ( (curbinder (unsafe_get_field :binder fbi))
              (curctype (unsafe_get_field :fbind_type fbi))
              (curvararg (instance class_nrep_variadic_argument
                                   :nrep_loc loc
                                   :nvarg_ctyp curctype
                                   :nvarg_variadic nprovariadic
                                   :nvarg_offset (make_integerbox discr_constant_integer fbix) 
                                   ))
              (curletbind (instance class_normal_let_binding
                                    :binder curbinder
                                    :letbind_loc loc
                                    :letbind_type curctype
                                    :letbind_expr curvararg))
              (curlocc (instance class_nrep_locsymocc
                                 :nrep_loc loc
                                 :nocc_ctyp curctype
                                 :nocc_symb curbinder
                                 :nocc_bind curletbind))
              )
         (multiple_put_nth letbindtup fbix curletbind)
         (list_append letbindthenlist curletbind)
         (debug "normexp_ifvariadic curletbind=" curletbind
                "\n.. curlocc=" curlocc "\n.. curctype=" curctype)
         (multiple_put_nth locsymtup fbix curlocc)
         (multiple_put_nth ctyptup fbix curctype)
         (assert_msg "check curctype" (is_a curctype class_ctype) curctype)
         (put_env newenv curletbind)             
         ))
      (debug "normexp_ifvariadic letbindthenlist=" letbindthenlist "\n.. letbindtup=" letbindtup 
             "\n.. sycmap=" sycmap
             "\n.. loc=" loc)
      (let ( (cvarsym (clone_symbol 'consumvariadic_))
             (nconsume (instance class_nrep_consume_variadic
                                 :nrep_loc loc
                                 :nconsva_variadic nprovariadic
                                 :nconsva_ctypes ctyptup
                                 ))
             (cvarbind (instance class_normal_let_binding
                                 :binder cvarsym
                                 :letbind_loc loc
                                 :letbind_type ctype_void
                                 :letbind_expr nconsume))
             )
        (list_append letbindthenlist cvarbind)
        )
      (debug "normexp_ifvariadic letbindthenlist=" letbindthenlist
             "\n.. letbindtup=" letbindtup
             "\n.. locsymtup=" locsymtup
             "\n.. ctyptup=" ctyptup
             " sthen=" sthen "\n.. loc=" loc)
      (multicall
       (nthen nthenbindings)
       (normalize_tuple sthen newenv ncx loc)
       (debug "normexp_ifvariadic nthen=" nthen " nthenbindings=" nthenbindings
              "\n.. loc=" loc)
       (list_append2list letbindthenlist nthenbindings)
       (debug "normexp_ifvariadic updated letbindthenlist=" letbindthenlist
              " selse=" selse "\n.. sycmap=" sycmap "\n.. loc=" loc)
       ;; forget every symbol in letbindtup from the sycmap, to fix MELT-SFT-8
       (foreach_in_multiple 
        (letbindtup)
        (curbind :long bix)
        (debug "normexp_ifvariadic curbind=" curbind "\n.. bix=" bix "\n.. loc=" loc)
        (let ( (cursym (get_field :binder curbind))
               (cachlocc (mapobject_get sycmap cursym))
               )
          (when cachlocc
            (assert_msg "check cachlocc" (is_a cachlocc class_nrep_locsymocc) cachlocc)
            (debug "normexp_ifvariadic forgetting cachlocc=" cachlocc "\n.. cursym=" cursym)
            (mapobject_remove sycmap cursym)))
        )
       (debug "normexp_ifvariadic cleaned sycmap=" sycmap "\n.. loc=" loc)
       ;;
       (multicall
        (nelse nelsebindings)
;;;; we had::: (normalize_tuple selse newenv ncx loc)
;;; but very probably the else don't need the supplementary binding...
        (normalize_tuple selse env ncx loc)
        (debug "normexp_ifvariadic nelse=" nelse " nelsebindings=" nelsebindings "\n.. loc=" loc)
        (let ( 
              (csym (clone_symbol 'ifvariadic_))
              (cbind (instance class_normal_let_binding
                               :binder csym
                               :letbind_loc loc
                               :letbind_type ctype_void
                               :letbind_expr () ;filled later
                               ))
              (clocc (instance class_nrep_locsymocc
                               :nrep_loc loc
                               :nocc_ctyp ctype_void
                               :nocc_symb csym
                               :nocc_bind cbind))
              (nthenlet 
               (progn
                 (debug "normexp_ifvariadic wrapping nthen=" nthen
                        "\n.. letbindthenlist=" letbindthenlist
                        "\n.. loc=" loc)
                 (wrap_normal_letseq nthen letbindthenlist loc)))
              (nelselet 
               (progn 
                 (debug "normexp_ifvariadic wrapping nelse=" nelse
                        "\n.. nelsebindings=" nelsebindings
                        "\n.. loc=" loc)
                 (wrap_normal_letseq nelse nelsebindings loc)))
              (nbindlist (list cbind))
              (nifv (instance class_nrep_ifvariadic
                              :nrep_loc loc
                              :nif_then nthenlet
                              :nif_else nelselet
                              :nifv_variadic nprovariadic
                              :nifv_ctypes ctyptup))
              )
          (debug "normexp_ifvariadic nifv=" nifv)
          (put_fields cbind :letbind_expr nifv)
          (debug "normexp_ifvariadic result clocc=" clocc " nbindlist=" nbindlist)
          (return clocc nbindlist)
          ))))))
(install_method class_source_ifvariadic normal_exp normexp_ifvariadic)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize the compile_warning
(defun normexp_compile_warning  (recv env ncx psloc)
  (debug "normexp_compile_warning recv=" recv)
  (assert_msg "check compilewarn recv" (is_a recv class_source_compile_warning) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ((sloc  (unsafe_get_field :loca_location recv)) 
        (swmsg (unsafe_get_field :scdiag_msg recv))
        (swexp (unsafe_get_field :scdiag_expr recv))
        )
    (warning_at sloc "COMPILE_WARNING: $1" swmsg)
    (multicall 
     (nexp nbind)
     (normal_exp swexp env ncx sloc)
     (debug "normexp_compile_warning nesult nexp=" nexp " nbind=" nbind)
     (return nexp nbind)
     )))

(install_method class_source_compile_warning normal_exp normexp_compile_warning)
(install_method class_source_compile_warning get_ctype 
                (lambda (recv env) (get_ctype (get_field :scdiag_expr recv) env)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize the compile_error
(defun normexp_compile_error  (recv env ncx psloc)
  (debug "normexp_compile_error recv=" recv)
  (assert_msg "check compileerror recv" (is_a recv class_source_compile_error) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ((sloc  (unsafe_get_field :loca_location recv)) 
        (swmsg (unsafe_get_field :scdiag_msg recv))
        (swexp (unsafe_get_field :scdiag_expr recv))
        )
    (error_at sloc "COMPILE_ERROR: $1" swmsg)
    (multicall 
     (nexp nbind)
     (normal_exp swexp env ncx sloc)
     (debug "normexp_compile_error nesult nexp=" nexp " nbind=" nbind)
     (return nexp nbind)
     )))

(install_method class_source_compile_error normal_exp normexp_compile_error)
(install_method class_source_compile_error get_ctype 
                (lambda (recv env) (get_ctype (get_field :scdiag_expr recv) env)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; 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) tup)
  (assert_msg "check env" (is_a env class_environment) env)
  (let ( (:long tuplen (multiple_length tup)) 
         (lastcomp (if (>i tuplen 0) (multiple_nth tup (-i tuplen 1)))) )
    (cond 
;;; last expression is already a return - do nothing
     ( (is_a lastcomp class_nrep_return)
       (return tup)
       )
;;; 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)
            (instance class_nrep_return
                      :nrep_loc sloc
                      :nret_main lastcomp)))
       (return tup)
       )
;;; last expression is a normal data, return it
     ( (is_a lastcomp class_nrep_bound_data)
       (multiple_put_nth 
        tup  (-i tuplen 1)
        (instance class_nrep_return
                  :nrep_loc sloc
                  :nret_main lastcomp))
       (return tup)
       )
;;; no last expression - don't bother to return
     ( (null lastcomp)
       (return tup)
       )
;;; 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_every
          lbinding
          (lambda (bnd :long ix)
            (put_env newenv bnd)
            ))
         (if (is_multiple lbody) 
             (replace_last_by_return lbody newenv lloc))
         (return tup)
         ))
;;; 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 (instance class_nrep_locsymocc 
                                      :nrep_loc loc
                                      :nocc_symb rclosym
                                      :nocc_ctyp ctype_value))
                    (retn (instance class_nrep_return
                                    :nrep_loc loc
                                    :nret_main rclocc
                                    ))
                    (rbind (instance class_normal_let_binding
                                     :binder rclosym
                                     :letbind_type ctype_value
                                     :letbind_expr lastcomp
                                     :letbind_loc loc
                                     ))
                    (rbintup (tuple rbind))
                    (rlet (instance class_nrep_let
                                    :nrep_loc loc
                                    :nlet_bindings rbintup
                                    :nlet_body (tuple retn)))
                    )
               (unsafe_put_fields rclocc :nocc_bind rbind)
               (multiple_put_nth 
                tup  (-i tuplen 1)
                rlet)
               (return tup)
               )))))
    (return tup)                        ; returns the original tuple
;;; general case, do nothing 
    )
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a DEFUN or a DEFMACRO
(defun normexp_defun_defmacro (recv env ncx psloc)
  (debug "normexp_defun_defmacro recv=" recv
         "\n.. env=" debug_more env
         "\n.. psloc=" psloc)
  (shortbacktrace_dbg "normexp_defun_defmacro" 8)
  (assert_msg "check defun recv" (is_a recv class_source_defun) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (or (unsafe_get_field :loca_location recv) psloc))
         (snam (get_field :sdef_name recv))
         (sformals (unsafe_get_field :sformal_args recv))
         (sbody (unsafe_get_field :sfun_body recv))
         (:long ismacro (is_a recv class_source_defmacro))
         (:long isletmacro (is_a recv class_source_defmacro_in_let))
         (modctx (get_field :nctx_modulcontext ncx))
         (modinienv (get_field :mocx_initialenv modctx))
         (macroenv (get_field :mocx_macroenv modctx))
         (basenv (progn
                   (debug "normexp_defun_defmacro" " sloc=" sloc
                          " ismacro=" ismacro " isletmacro=" isletmacro
                          "\n.. env=" env
                          "\n.. macroenv=" macroenv)
                   (let
                       ( 
                        (be (cond
                             (isletmacro
                              (debug "normexp_defun_defmacro" " isletmacro basenv=env=" debug_less env)
                              env)
                             (ismacro
                              (debug "normexp_defun_defmacro" " ismacro basenv=macroenv=" debug_less macroenv)
                              macroenv)
                             (:else
                              (debug "normexp_defun_defmacro" " nonmacro basenv=env=" debug_less env)
                              env)))
                        )
                     (debug "normexp_defun_defmacro sloc=" debug_less sloc
                            "; basenv=" be)
                     (debug "normexp_defun_defmacro snam=" snam
                            "\n in env got:" (find_env env snam)
                            "\n in macroenv got:" (find_env macroenv snam))
                     (assert_msg "check basenv" (is_a be class_environment))
                     be)))
         (sfubind (find_env basenv snam))
         (newenv (fresh_env basenv))
         (oldproc (unsafe_get_field :nctx_curproc ncx))
         (oldsymbcache (unsafe_get_field :nctx_symbcachemap ncx))
         (closblis (make_list discr_list))
         (cnstlist (make_list discr_list))
         (nproc (instance class_nrep_defunroutproc
;;; dont forget to put the nil fields at end
                          :nrep_loc sloc
                          :nproc_body () ;filled later
                          :nrclop_name snam
                          :nrclop_argbindtuple sformals
                          :nrclop_clobindlist closblis
                          :nrclop_constlist cnstlist
                          :nrclop_objconstcachemap (make_mapobject discr_map_objects 31)
                          :nrpro_thunklist (make_list discr_list)
                          :nrpro_datarout () ; filled below
                          :nrpro_dataclos () ; filled below
                          :nrpro_variadic () ; filled below
                          ))
         (ndatarout (instance class_nrep_dataroutine
                              :ndata_name snam
                              :ndata_discrx (normal_predef discr_routine ncx sloc "discr_routine")
                              :ndrou_proc nproc
                              ))
         (ndataclos (instance class_nrep_dataclosure
                              :ndata_name snam
                              :ndata_discrx 
                              (if ismacro
                                  (normal_predef discr_macro_closure ncx sloc "discr_macro_closure")
                                (normal_predef discr_closure ncx sloc "discr_closure"))
                              :ndclo_proc nproc
                              :ndclo_closv () ;filled below
                              ))
         )
    (debug "normexp_defun_defmacro ismacro=" ismacro "; sloc=" debug_less sloc 
           "\n.. basenv=" (if ismacro debug_more debug_less) basenv 
           "\n.. newenv=" newenv)
    (unsafe_put_fields ncx 
                       :nctx_curproc nproc
                       :nctx_symbcachemap (make_mapobject discr_map_objects 40))
    (debug "normexp_defun_defmacro nproc=" nproc 
           "\n.. ndatarout=" ndatarout 
           "\n.. ndataclos=" ndataclos
           "\n.. newenv=" newenv)
    (add_nctx_data ncx ndatarout)
    (add_nctx_data ncx ndataclos)
    (debug "normexp_defun_defmacro updated ncx=" debug_less ncx "\n.. sloc=" debug_less sloc
           "\n.. sfubind=" sfubind)
    (when (null sfubind)
      (debug "normexp_defun_defmacro null sfubind ismacro=" ismacro 
             " from basenv=" debug_more basenv 
             "\n... snam=" snam "\n.. recv=" recv "\n")
      (if ismacro
          (error_at sloc
                    "bad defmacro-ed function $1 without binding" (get_field :named_name snam))
        (error_at sloc "bad defun-ed function $1 without binding" (get_field :named_name snam)))
      (shortbacktrace_dbg "normexp_defun_defmacro bad DEFUNed unbound function" 14)
      (return))
    (when (and 
           (is_not_a sfubind class_function_binding)
           (is_not_a sfubind class_macro_binding)
           (is_not_a sfubind class_defined_macro_binding))
      (debug "normexp_defun_defmacro strange sfubind=" sfubind)
      (if ismacro
          (error_at sloc
                    "bad defmacro-ed function $1 with binding of $2 [nested definitions are prohibited]"
                    (get_field :named_name snam) (get_field :named_name (discrim sfubind)))
          
        (error_at sloc
                  "bad defun-ed function $1 with binding of $2 [nested definitions are prohibited]"
                  (get_field :named_name snam) (get_field :named_name (discrim sfubind))))
      (shortbacktrace_dbg "normexp_defun_defmacro bad DEFUNed function" 14)
      (return))
    (unsafe_put_fields nproc :nrpro_datarout ndatarout :nrpro_dataclos ndataclos)
    (debug "normexp_defun_defmacro updated nproc=" nproc)
    (foreach_in_multiple 
     (sformals)
     (fbi :long ix)
     (assert_msg "check fbi" (is_a fbi class_formal_binding) fbi)
     (put_env newenv fbi))
    (if (is_a sformals discr_variadic_formal_sequence)
        (put_fields nproc :nrpro_variadic snam))
    (unsafe_put_fields newenv :env_proc nproc)
    (debug "normexp_defun_defmacro updated :env_proc of of newenv" debug_more newenv)
    (shortbacktrace_dbg "normexp_defun_defmacro update-envproc" 10)
    ;; add nproc into ncx
    (let ( (ncplis (get_field :nctx_proclist ncx)) 
           )
      (list_append ncplis nproc)
      (debug "normexp_defun_defmacro appended to nctxproclist ncplis=" ncplis
             "\n.. ncx=" ncx)
      (shortbacktrace_dbg "normexp_defun_defmacro" 15)
      )
    ;;
    (multicall
     (nbody nbindings)
     (normalize_tuple sbody newenv ncx sloc)
     (debug "normexp_defun_defmacro nbody before replace_last_by_return" nbody)
     (multiple_every
      nbindings
      (lambda (nbi :long ix)
        (put_env newenv nbi)))
     (let ( (nrbody (replace_last_by_return nbody newenv sloc)) 
            (npbody (wrap_normal_letseq nrbody nbindings sloc))
            )
       (unsafe_put_fields nproc  :nproc_body npbody)
       (debug "normexp_defun_defmacro after replace_last_by_return npbody=" npbody "\n.. nproc=" nproc)
       )
     (unsafe_put_fields ncx :nctx_curproc oldproc :nctx_symbcachemap oldsymbcache)
     (debug "normexp_defun_defmacro restored ncx=" ncx)
     (let ( (clovtup 
             (list_to_multiple 
              closblis
              discr_multiple
              (lambda (bnd)
                (assert_msg "normexp_defun_defmacro check bnd" (is_a bnd class_any_binding) bnd)
                (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* base environment, not the new one
                       (nsy (normal_exp sy basenv ncx sloc))
                       )
                  nsy
                  )))) )
       (unsafe_put_fields ndataclos :ndclo_closv clovtup)
       )
     ;; link the binding and the data
     (cond ( (is_a sfubind class_function_binding)
             (unsafe_put_fields sfubind :fixbind_data ndataclos))
           ( (is_a sfubind class_defined_macro_binding)
             (unsafe_put_fields sfubind :mbind_data ndataclos))
           ( (is_a sfubind class_macro_binding)
             (cond ( (and (melt_is_bootstrapping)
                          (== (get_field :binder sfubind) (get_field :ndata_name ndataclos)))
                     (debug "normexp_defun_defmacro good bootstrapping macro sfubind=" sfubind "\n ndataclos=" ndataclos)
                     (void))
                   (:else
                    (error_at  sloc "messy definition of $1 with existing macro binding"
                               snam)
                    (assert_msg "strange macro sfubind & ndataclos" () sfubind ndataclos)
                    (return))))
           (:else
            (debug "normexp_defun_defmacro strange sfubind=" sfubind "\n.. for ndataclos=" ndataclos)
            (assert_msg "bad sfubind" () sfubind ndataclos)))
     (debug "normexp_defun_defmacro return ndataclos=" ndataclos)
     (return ndataclos ())
     )
    ))
(install_method class_source_defun normal_exp normexp_defun_defmacro)


;;; normalize the installation of a macro
(defun normexp_macro_installation (recv env ncx psloc)
  (debug "normexp_macro_installation recv=" recv "\n... env=" env)
  (assert_msg "check recv" (is_a recv class_source_macro_installation) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (shortbacktrace_dbg "normexp_macro_installation" 16)
  (let ( (loc (or (unsafe_get_field :loca_location recv) psloc))
         (sdefmacro (unsafe_get_field :smacinst_defmacro recv))
         (modctx (get_field :nctx_modulcontext ncx))
         (macroenv (get_field :mocx_macroenv modctx))
         (modname (get_field :mocx_modulename modctx))
         (srcenv (get_field :smacinst_env recv))
         )
    (debug "normexp_macro_installation" " loc=" debug_less loc "; sdefmacro=" sdefmacro
           "\n.. macroenv=" debug_more macroenv
           "\n.. srcenv=" debug_more srcenv)
    (assert_msg "check modctx" (is_a modctx class_any_module_context) modctx)
    (assert_msg "check macroenv" (is_a macroenv class_environment) macroenv)
    (assert_msg "check srcenv" (is_a srcenv class_environment) srcenv)
    (assert_msg "check sdefmacro" (is_a sdefmacro class_source_defmacro) sdefmacro)
    (debug "normexp_macro_installation" " before normalizing loc=" loc "; sdefmacro=" sdefmacro)
    (let (
          (nclos (normexp_defun_defmacro sdefmacro srcenv ncx loc))
          (mbind (get_field :smacro_binding sdefmacro))
          (msymb (get_field :binder mbind))
          )
      (debug "normexp_macro_installation" " loc=" debug_less loc "; nclos=" nclos
             "\n.. mbind=" mbind "\n.. macroenv=" macroenv
             "\n")
      (assert_msg "check modctx" (is_a modctx class_running_extension_module_context) modctx recv)
      (assert_msg "check nclos" (is_a nclos class_nrep_dataclosure) nclos env recv)
      (assert_msg "check mbind" (is_a mbind class_defined_macro_binding) mbind env recv)
      (let ( 
            (nlitsym (clone_symbol msymb))
            (nclosym (clone_symbol msymb))
            (nlitbind (let ( (nli (register_literal_value mbind modctx)) )
                        (debug "normexp_macro_installation" " nlitbind=" nli)
                        nli))
            (clobind (instance class_normal_let_binding
                               :letbind_loc loc
                               :binder nclosym
                               :letbind_type ctype_value
                               :letbind_expr nclos))
            (closocc (instance class_nrep_locsymocc
                               :nrep_loc loc
                               :nocc_ctyp ctype_value
                               :nocc_symb nclosym
                               :nocc_bind clobind))
            (nlitval (let ( (nlv (instance class_nrep_literalnamedvalue
                                           :nlitval_regval nlitbind
                                           :nlitval_symbol nlitsym))
                            )
                       (debug "normexp_macro_installation" " nlitval=" nlv)
                       nlv))
            (nhcall  (let ( (nhc (instance class_nrep_hook_call
                                           :nrep_loc loc
                                           :nexpr_ctyp ctype_void
                                           :nhook_name '"HOOK_MACRO_INSTALLER"
                                           :nexpr_args (tuple nlitval closocc)
                                           :nhook_called (normal_predef hook_macro_installer ncx
                                                                        loc "hook_macro_installer")
                                           :nhook_outs (tuple)
                                           :nhook_descr (hook_data hook_macro_installer)
                                           )) )
                       (debug "normexp_macro_installation" " nhcall=" nhc "\n.. loc=" loc)
                       nhc))
            (csym (clone_symbol (get_field :binder mbind)))
            (cbind (instance class_normal_let_binding
                             :letbind_loc loc
                             :binder csym
                             :letbind_type ctype_void
                             :letbind_expr nhcall))
            (symocc (instance class_nrep_locsymocc
                              :nrep_loc loc
                              :nocc_ctyp ctype_void
                              :nocc_symb csym
                              :nocc_bind cbind))
            )
        (debug "normexp_macro_installation" " nlitval=" nlitval "\n.. loc=" loc)
        (debug "normexp_macro_installation" " csym=" csym " nhcall=" nhcall)
        (debug "normexp_macro_installation" " final closocc=" closocc "\n.. symocc=" symocc 
               "\n.. cbind=" cbind "\n.. clobind=" clobind)
        (return (tuple closocc symocc) (list clobind cbind))
        ))))
(install_method class_source_macro_installation normal_exp normexp_macro_installation)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a DEFHOOK
(defun normexp_defhook (recv  env ncx psloc)
  (debug "normexp_defhook recv=" recv "\n.. ncx=" ncx "\n.. env=" env)
  (assert_msg "check defhook recv" (is_a recv class_source_defhook) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (unsafe_get_field :loca_location recv))
         (symb (get_field :sdef_name recv))
         (symbname (progn 
                     (debug "normexp_defhook symb=" symb)
                     (let ( (sn (get_field :named_name symb))
                            )
                       (debug "normexp_defhook symbname=" sn)
                       sn)))
         (sinformals (unsafe_get_field :sformal_args recv))
         (soutformals (unsafe_get_field :shook_out_formals recv))
         (sctype (unsafe_get_field :shook_ctype recv))
         (spredef (unsafe_get_field :shook_predef recv))
         (smodvar (unsafe_get_field :shook_variable recv))
         (sbody (unsafe_get_field :shook_body recv))
         (shobind (find_env env symb))
         (newenv (fresh_env env))
         (oldproc (unsafe_get_field :nctx_curproc ncx))
         (oldsymbcache (unsafe_get_field :nctx_symbcachemap ncx))
         (closbindlist (make_list discr_list))
         (constlist (make_list discr_list))
         (nproc (instance class_nrep_hookproc
                          :nrep_loc sloc
                          :nproc_body ()
                          :nrclop_name symbname
                          :nrclop_argbindtuple ()
                          :nrhook_outb ()
                          :nrhook_ctype sctype
                          :nrhook_datahook ()
                          :nrclop_clobindlist closbindlist
                          :nrclop_constlist constlist
                          :nrclop_objconstcachemap (make_mapobject discr_map_objects 31)
                          ))
         (descrhook (instance class_hook_descriptor
                              :named_name symbname
                              :hookdesc_in_formals sinformals
                              :hookdesc_out_formals soutformals
                              :hookdesc_ctype sctype
                              :hookdesc_hook ()))
         (ndatahook (instance class_nrep_datahook
                              :ndata_name symbname
                              :ndata_discrx (normal_predef discr_hook ncx sloc "discr_hook")
                              :ndhook_proc nproc
                              :ndhook_data ()
                              :ndhook_closv ()
                              :ndhook_predef spredef
                              :ndhook_modvarbind ()
                              ))
         ;; map of formal symbol -> data of formal_binding
         (formsymbmap (make_mapobject discr_map_objects
                                      (+i 9 (*i (+i (multiple_length sinformals) (multiple_length soutformals)) 2))))
         (formintuple (make_multiple discr_multiple (multiple_length sinformals)))
         (formoutuple (make_multiple discr_multiple (multiple_length soutformals)))                  
         (namstrdata (instance class_nrep_datastring
                               :nrep_loc sloc
                               :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
                               :nstr_string  symbname))
         (slotup (make_multiple discr_multiple
                                (multiple_length (unsafe_get_field :class_fields class_hook_descriptor))))
         (insdata (instance class_nrep_datainstance
                            :nrep_loc sloc
                            :ndata_name symbname
                            :ndata_discrx (normal_predef class_hook_descriptor ncx sloc "class_hook_descriptor") 
                            :ninst_hash (make_integerbox discr_integer (obj_hash descrhook))
                            :ninst_slots slotup
                            )) 
         )
    (put_fields ndatahook :ndhook_data insdata)
    (put_fields nproc :nrhook_datahook ndatahook)
    (debug "normexp_defhook newenv=" newenv
           "\n.. oldproc=" oldproc "\n.. nproc=" nproc)
    (debug "normexp_defhook ndatahook=" ndatahook "\n.. sctype=" sctype)
    (debug "normexp_defhook descrhook=" descrhook "\n.. smodvar=" smodvar) 
    (if smodvar
        (let ( (modvarbind (find_env env smodvar))
               )
          (debug "normexp_defhook symbname=" symbname " smodvar=" smodvar " modvarbind=" modvarbind)
          (when (is_not_a modvarbind class_normal_module_variable_binding)
            (error_at sloc "DEFHOOK $1 has bad :VAR annotation, should be a module variable"_
                        symbname)
            (return)
            )
          (put_fields ndatahook :ndhook_modvarbind modvarbind)
          (debug "normexp_defhook updated ndatahook=" ndatahook)
          ))
    (assert_msg "check sctype" (is_a sctype class_ctype) sctype)
    (assert_msg "check symbname" (is_string symbname) symbname)
    (assert_msg "check sinformals" (and (is_multiple_or_null sinformals)
                                        (is_not_a sinformals discr_variadic_formal_sequence))
                sinformals)
    (assert_msg "check soutformals" (and (is_multiple_or_null soutformals)
                                         (is_not_a soutformals discr_variadic_formal_sequence))
                soutformals)
    (debug "normexp_defhook shobind=" shobind "\n oldproc=" oldproc " \n nproc=" nproc
           "\n ndatahook=" ndatahook)
    (put_fields ncx 
                :nctx_curproc nproc
                :nctx_symbcachemap (make_mapobject discr_map_objects 40))
    (add_nctx_data ncx ndatahook)
    (add_nctx_data ncx insdata)
    (when (is_not_a shobind class_hook_binding)
      (error_at sloc
                "bad hook definition $1, not bound to a hook but $2 [nested hooks are prohibited]"
                symbname (get_field :named_name (discrim shobind)))
      (return))
;;; fill the named_name of insdata
    (debug "normexp_defhook namstrdata=" namstrdata)
    (add_nctx_data ncx namstrdata)
    (multiple_put_nth slotup (get_int named_name) namstrdata)
    ;; fill the hookdesc_in_formals of insdata
    (fill_normal_formals sinformals formintuple formsymbmap env ncx sloc)
    (let ( (nintupdata (instance class_nrep_datatuple
                                 :nrep_loc sloc
                                 :ndata_name symbname
                                 :ndata_discrx  (normal_predef discr_multiple ncx sloc "discr_multiple")
                                 :ntup_comp formintuple))
           )
      (add_nctx_data ncx nintupdata)
      (multiple_put_nth slotup (get_int hookdesc_in_formals) nintupdata)
      (debug "normexp_defhook nintupdata=" nintupdata))
    ;; fill the hookdesc_out_formals of insdata
    (fill_normal_formals soutformals formoutuple formsymbmap env ncx sloc)
    (let ( (noutupdata (instance class_nrep_datatuple
                                 :nrep_loc sloc
                                 :ndata_name symbname
                                 :ndata_discrx  (normal_predef discr_multiple ncx sloc "discr_multiple")
                                 :ntup_comp formoutuple))
           )
      (add_nctx_data ncx noutupdata)
      (multiple_put_nth slotup (get_int hookdesc_out_formals) noutupdata)
      (debug "normexp_defhook noutupdata=" noutupdata))
    ;; fill the hookdesc_ctype of insdata
    (multiple_put_nth slotup (get_int hookdesc_ctype) (normal_predef sctype ncx sloc "hook ctype"))
    ;;
    (debug "normexp_defhook slotup=" slotup)
    ;;
    (debug "normexp_defhook updated ncx=" ncx "\n .. nproc=" nproc)
    (foreach_in_multiple
     (sinformals)
     (fbi :long ix)
     (assert_msg "check fbi" (is_a fbi class_formal_binding) fbi)
     (put_env newenv fbi))
    (foreach_in_multiple
     (soutformals)
     (fbo :long ix)
     (assert_msg "check fbo" (is_a fbo class_formal_binding) fbo)
     (put_env newenv fbo))
    (put_fields nproc 
                :nrclop_argbindtuple sinformals
                :nrhook_outb soutformals)
    (put_fields newenv :env_proc nproc)
    (debug "normexp_defhook updated newenv=" newenv)
    ;;
    (multicall
     (nbody nbindings)
     (normalize_tuple sbody newenv ncx sloc)
     (debug "normexp_defhook nbody=" nbody "\n.. nbindings=" nbindings)
     ;; add nproc into ncx
     (let ( (ncplis (get_field :nctx_proclist ncx)) 
            )
       (list_append ncplis nproc)
       (debug "normexp_defhook sbody=" sbody "\n.. updated ncx=" ncx "\n.. ncplis=" ncplis)
       )
     (shortbacktrace_dbg "normexp_defhook" 12)
     ;; make the bindings in the newenv
     (foreach_in_multiple
      (nbindings)
      (nbi :long bix)
      (put_env newenv nbi))
     (debug "normexp_defhook updated newenv=" newenv)
     ;; restore the previous symbol cache map & the old proc 
     (put_fields ncx 
                 :nctx_symbcachemap oldsymbcache
                 :nctx_curproc oldproc
                 )
     (debug "normexp_defhook restored ncx=" ncx)
     (debug "normexp_defhook closbindlist=" closbindlist "\n.. constlist=" constlist)
     (assert_msg "check closbindlist" (is_list closbindlist) closbindlist)
     (assert_msg "check constlist" (is_list constlist) constlist)
     ;; normalize the closed and the const values
     (let ( (nseq (wrap_normal_letseq nbody nbindings sloc))
            (:long nbclosbind (list_length closbindlist))
            (:long nbconst (list_length constlist))
            (:long ix 0)
            (closvtup (make_multiple discr_multiple (+i nbclosbind nbconst)))
            )
       (debug "normexp_defhook nbclosbind#" nbclosbind " nbconst#" nbconst)
       ;;
       (foreach_pair_component_in_list 
        (closbindlist)
        (curpair curclobnd)
        (debug "normexp_defhook curclobnd=" curclobnd " ix#" ix)
        (assert_msg "check curclobnd" (is_a curclobnd class_any_binding) curclobnd)
        (let ( (sy (unsafe_get_field :binder curclobnd)) 
               ;; normalize in the *old* environment
               (nsy (normal_exp sy env ncx sloc))
               )
          (debug "normal_exp nsy=" nsy)
          (multiple_put_nth closvtup ix nsy)
          (setq ix (+i ix 1))
          ))                            ;end foreach closbindlist
       (debug "normexp_defhook after closbindloop ix=" ix " closvtup=" closvtup)
       ;;
       (debug "normexp_defhook closing constlist=" constlist)
       (foreach_pair_component_in_list
        (constlist)
        (curpair curconst)
        (debug "normexp_defhook curconst=" curconst " ix#" ix)
        (assert_msg "check curconst" (is_a curconst class_nrep) curconst)
        (multiple_put_nth closvtup ix curconst)
        (setq ix (+i ix 1))
        )                               ;end foreach constlist
       (debug "normexp_defhook after constlistloop ix=" ix " closvtup=" closvtup)
       (assert_msg "check final ix" (==i ix (+i nbclosbind nbconst)) ix)
       ;;
       (debug "normexp_defhook nseq=" nseq "\n ..final closvtup=" closvtup)
       (put_fields nproc :nproc_body nseq)
       (put_fields ndatahook :ndhook_closv closvtup)
       (put_fields shobind :fixbind_data ndatahook)
       (debug "normexp_defhook final nproc=" nproc)
       (debug "normexp_defhook final ndatahook=" ndatahook 
              "\n.. shobind=" shobind)
       ;;
       (debug "normexp_defhook result nproc=" nproc)
       (return nproc ())
       ))))
(install_method class_source_defhook normal_exp normexp_defhook)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a LAMBDA

;;; an internal routine useful for lambda inside letrec ... to share
;;; code between normexp_lambda and handling of lambda-s inside letrec
(defun normalize_lambda (recv env newenv ncx psloc)
  (debug "normalize_lambda recv=" recv "\n.. env=" env "\n.. newenv=" newenv
         "\n ncx=" debug_less ncx)
  (shortbacktrace_dbg "normalize_lambda" 15)
  (assert_msg "check lambda recv" (is_a recv class_source_lambda) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check newenv" (is_a newenv class_environment))
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (unsafe_get_field :loca_location recv))
         (sformalargs (unsafe_get_field :slam_argbind recv))
         (sbody (unsafe_get_field :slam_body recv))
         (:long ismacrosrc (is_a recv class_source_lambda_for_macro))
         (csym (if ismacrosrc
                   (clone_symbol 'lambdamacro_) 
                 (clone_symbol 'lambda_)))
         (clocc (instance class_nrep_locsymocc
                          :nrep_loc sloc
                          :nocc_ctyp ctype_value
                          :nocc_symb csym)) 
         (oldproc (unsafe_get_field :nctx_curproc ncx))
         (savedcachemap (unsafe_get_field :nctx_symbcachemap ncx))
         (closedblist (make_list discr_list))
         (cnstlist (make_list discr_list))
         (nproc (if ismacrosrc
                    (instance class_nrep_macrolambdaroutproc
                          :nrep_loc sloc
                          :nproc_body () ;filled later
                          :nrclop_name csym
                          :nrclop_argbindtuple sformalargs
                          :nrclop_clobindlist closedblist
                          :nrclop_constlist cnstlist
                          :nrclop_objconstcachemap (make_mapobject discr_map_objects 31)
                          :nrpro_datarout () ; filled below
                          :nrpro_dataclos () ; not filled
                          :nrpro_thunklist (make_list discr_list)
                          :nrpro_variadic () ; filled below
                              )
                    (instance class_nrep_lambdaroutproc
                          :nrep_loc sloc
                          :nproc_body () ;filled later
                          :nrclop_name csym
                          :nrclop_argbindtuple sformalargs
                          :nrclop_clobindlist closedblist
                          :nrclop_constlist cnstlist
                          :nrclop_objconstcachemap (make_mapobject discr_map_objects 31)
                          :nrpro_datarout () ; filled below
                          :nrpro_dataclos () ; not filled
                          :nrpro_thunklist (make_list discr_list)
                          :nrpro_variadic () ; filled below
                          )))
         (ndatarout (instance class_nrep_dataroutine
                              :nrep_loc sloc
                              :ndata_name csym
                              :ndata_discrx (normal_predef discr_routine ncx sloc "discr_routine")
                              :ndrou_proc nproc
                              ))
         )
    (debug "normalize_lambda" " sloc=" sloc " made nproc=" nproc "\n.. ndatarout=" ndatarout)
    (shortbacktrace_dbg "normalize_lambda" 12)
    (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_map_objects 40))
    (put_fields nproc :nrpro_datarout ndatarout)
    (debug "normalize_lambda" " sloc=" sloc " updated ncx=" ncx "\n.. nproc=" nproc)
    (foreach_in_multiple
     (sformalargs)
     (fbi :long ix)
     (assert_msg "check fbi" (is_a fbi class_formal_binding) fbi)
     (put_env newenv fbi))
    (if (is_a sformalargs discr_variadic_formal_sequence)
        (put_fields nproc :nrpro_variadic csym))
    (debug "normalize_lambda"  " sloc=" sloc " before updating newenv=" newenv)
    (put_fields newenv :env_proc nproc)
    (debug "normalize_lambda"  " sloc=" sloc " updated newenv=" debug_more newenv)
    (shortbacktrace_dbg "normalize_lambda" 15)
    ;; add nproc into ncx
    (let ( (ncplis (get_field :nctx_proclist ncx)) 
           )
      (list_append ncplis nproc)
      (debug "normalize_lambda"  " sloc=" sloc " updated ncplis=" ncplis "\n.. ncx=" ncx)
    )
    ;;
    (multicall
     (nbody nbindings)
     (normalize_tuple sbody newenv ncx sloc)
     (debug "normalize_lambda" " sloc=" sloc " nbody=" nbody "\n.. nbindings=" nbindings)
     (foreach_in_multiple
      (nbindings)
      (nbi :long ix)
      (put_env newenv nbi))
     (put_fields 
      nproc
      :nproc_body (wrap_normal_letseq (replace_last_by_return nbody newenv sloc) nbindings sloc)
      )
     (debug "normalize_lambda" " sloc=" sloc " newenv=" newenv "\n.. nproc=" nproc)
     ;; restore the previous symbol cache map & the old proc and return the normalized lambda
     (put_fields ncx 
                 :nctx_symbcachemap savedcachemap
                 :nctx_curproc oldproc
                 )
     (debug "normalize_lambda restored ncx=" ncx "\n.. updated nproc=" nproc
            "\n.. oldproc=" oldproc
            "\n.. closedblist=" closedblist)
     (let ( 
           ;; we make an anonymous constant for the routine unless in toplevel
           (:long insideflag (let ( (insfl (is_a oldproc class_nrep_closproc))
                                    )
                               (debug "normalize_lambda insideflag=" insfl)
                               insfl))
           (krout (if insideflag
                      (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 "normalize_lambda:lambdaclos" " sloc=" sloc "; bnd=" bnd)
               (shortbacktrace_dbg "normalize_lambda:lambdaclos" 10)
               (assert_msg "normalize_lambda check bnd" (is_a bnd class_any_binding) bnd)
               (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))
                      )
                 (debug "normalize_lambda:lambdaclos" " sloc=" sloc "; nsy=" nsy)
                 nsy))))
           (constrout  (if insideflag krout ndatarout))
           )
       (debug "normalize_lambda" " sloc=" sloc " insideflag=" insideflag
              "\n.. constrout=" constrout)
       (shortbacktrace_dbg "normalize_lambda returning" 8)
       (debug "normalize_lambda" " final ncx=" ncx
              "\n final env=" env
              "\n final newenv=" newenv)
       (debug "normalize_lambda" " return nproc=" nproc
              "\n.. csym=" csym 
              "\n.. clocc=" clocc 
              "\n.. constrout=" constrout
              "\n.. clovtup=" clovtup
              "\n.. sloc=" sloc
              "\n.. oldproc=" oldproc
              "\n.. ndatarout=" ndatarout
              "\n.. insideflag=" insideflag "\n")
       (return nproc csym clocc constrout clovtup sloc oldproc ndatarout insideflag)
       ))))

;;;;
(defun normexp_lambda (recv env ncx psloc)
  (debug "normexp_lambda recv=" recv "\n..env=" env "\n.. ncx=" ncx)
  (assert_msg "check lambda recv" (is_a recv class_source_lambda) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let (
        (newenv (fresh_env env))
        )
    (debug "normexp_lambda before normalize_lambda newenv=" newenv)
    (multicall 
     (nproc csym clocc constrout clovtup sloc oldproc ndatarout :long insideflag)
     (normalize_lambda recv env newenv ncx psloc)
     (debug "normexp_lambda after normalize_lambda nproc=" nproc "\n.. csym=" csym 
            "\n.. clocc=" clocc "\n.. constrout=" constrout "\n.. clovtup=" clovtup
            "\n.. sloc=" sloc "\n.. oldproc=" oldproc "\n.. ndatarout=" ndatarout
            "\n.. insideflag=" insideflag
            "\n.. newenv=" debug_more newenv)
     (let (
           (nlambda (instance class_nrep_lambda 
                              :nrep_loc sloc
                              :nlambda_proc nproc
                              :nlambda_constrout constrout
                              :nlambda_closedv clovtup
                              ))
           (cbind (instance class_normal_let_binding
                            :letbind_loc sloc
                            :binder csym
                            :letbind_type ctype_value
                            :letbind_expr nlambda))
           (nbindlist (make_list discr_list))
           )
       (unsafe_put_fields clocc :nocc_bind cbind)
       (list_append nbindlist cbind)
       (debug "normexp_lambda insideflag=" insideflag " oldproc=" oldproc)
       (when insideflag
         (list_append (get_field :nrclop_constlist oldproc) ndatarout)
         (debug "normexp_lambda updated constlist in oldproc=" oldproc)
         )
       (debug "normexp_lambda return clocc=" clocc " nbindlist=" nbindlist)
       (return clocc nbindlist)
       ))))
(install_method class_source_lambda normal_exp normexp_lambda)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun normexp_multicall (recv env ncx psloc)
  (assert_msg "check multicall recv" (is_a recv class_source_multicall) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (debug "normexp_multicall recv" recv)
  (let ( (sloc (unsafe_get_field :loca_location recv))
         (sresbind (unsafe_get_field :smulc_resbind recv))
         (scall (unsafe_get_field :smulc_call recv))
         (sbody (unsafe_get_field :smulc_body recv))
         (newenv (fresh_env env))
         )
    (debug "normexp_multicall scall" scall)
    (multicall
     (ncall ncallbindings)
     (normal_exp scall env ncx sloc)
     (debug "normexp_multicall ncall=" ncall " ncallbindings=" ncallbindings)
;;; since ncall is normalized, it is a class_nrep_locsymocc and
;;; the last binding in ncallbindings is a class_normal_let_binding
;;; whose binder is the nocc_symb of the ncall
     (assert_msg "normexp_multicall check ncall" (is_a ncall class_nrep_locsymocc) ncall)
     (let ( (ncallsym (unsafe_get_field :nocc_symb ncall)) 
            (ncontcall (reference ())) ;container to contain the real normalized call
            (nrealcall ())                     ;the real call
            (nincallbindings (make_list discr_list)) ;list of internal bindings to the call
            )
       (list_iterate_test       ;loop exited when cbnd is for ncallsym
        ncallbindings
        (lambda (cbnd)
          (assert_msg "normexp_multicall check cbnd" (is_a cbnd class_normal_let_binding) cbnd)
          (if (== ncallsym (unsafe_get_field :binder cbnd))
              (let ( (nrealcallex (unsafe_get_field :letbind_expr cbnd)) )
                (set_ref ncontcall nrealcallex)
                (return () ()))
            (progn (list_append nincallbindings cbnd) 
                   (return cbnd ())))
          ))
       (setq nrealcall (deref ncontcall))
       (debug "normexp_multicall got nrealcall" nrealcall)
       (multiple_every
        sresbind
        (lambda (bnd :long ix)
          (put_env newenv bnd)))
       (multicall
        (nbody nbodybindings)
        (normalize_tuple sbody newenv ncx sloc)
        (debug "normexp_multicall nbody=" nbody " nbodybindings=" nbodybindings)
        (let ( (wnbodylet (wrap_normal_letseq nbody nbodybindings sloc)) )
;;; remove every locally bound symbol from the symbol cache map
          (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx)) )
            (multiple_every sresbind
                            (lambda (bnd)
                              (mapobject_remove sycmap (unsafe_get_field :binder bnd))
                              )))
          (let ( 
                (lastnbody (multiple_nth nbody -1))
                (lastntype (if lastnbody (get_ctype lastnbody newenv) ctype_void))
                (csym (clone_symbol 'multi_))
                (cbind (instance class_normal_let_binding
                                 :binder csym
                                 :letbind_loc sloc
                                 :letbind_type lastntype
                                        ; :letbind_expr  filled below
                                 ))
                (clocc (instance class_nrep_locsymocc
                                 :nrep_loc sloc
                                 :nocc_ctyp lastntype
                                 :nocc_symb csym
                                 :nocc_bind cbind))
                )
;;; handle differently apply & sends
            (cond
             ( (is_a scall class_source_apply)
               (assert_msg "normexp_multicall check nrealcall apply" (is_a nrealcall class_nrep_apply) nrealcall)
               (let ( (nres (instance class_nrep_multiapply
                                      :nrep_loc sloc
                                      :napp_fun (unsafe_get_field :napp_fun nrealcall)
                                      :nexpr_args (unsafe_get_field :nexpr_args nrealcall)
                                      :nexpr_ctyp lastntype
                                      :nmulapp_bindings sresbind
                                      :nmulapp_body wnbodylet)) )
                 (unsafe_put_fields cbind :letbind_expr nres)
                 (list_append nincallbindings cbind)
                 (debug "normexp_multicall multiapply result clocc=" clocc
                        " nincallbindings=" nincallbindings)
                 (return clocc nincallbindings)
                 )
               )
             ( (is_a scall class_source_msend)
               (debug "normexp_multicall multicall nrealcall" nrealcall)
               (compile_warning "in normexp_multicall we should check against the formals of the selector if available")
               (assert_msg "normexp_multicall check nrealcall send" (is_a nrealcall class_nrep_msend) nrealcall)
               (let ( (nrecv (get_field :nsend_recv nrealcall)) 
                      (nres (instance class_nrep_multimsend
                                      :nrep_loc sloc                          
                                      :nexpr_ctyp lastntype 
                                      :nsend_sel (unsafe_get_field :nsend_sel nrealcall)
                                      :nsend_recv nrecv
                                      :nexpr_args (unsafe_get_field :nexpr_args nrealcall)
                                      :nmulsend_bindings sresbind
                                      :nmulsend_body wnbodylet)) 
                      )
                 (debug "normexp_multicall nrecv from multicall=" nrecv)
                 (assert_msg "check nrecv" (is_object nrecv) nrecv)
                 (unsafe_put_fields cbind :letbind_expr nres)
                 (list_append nincallbindings cbind)
                 (debug "normexp_multicall multisend result clocc=" clocc
                        " nincallbindings=" nincallbindings)
                 (return clocc nincallbindings)
                 )
               )
             ( :else
               (error_at sloc "MULTICALL-ed expression neither apply nor send")
               (return ())
               )
             ))))))))

(install_method class_source_multicall normal_exp normexp_multicall)

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


(defun normexp_tuple (recv env ncx psloc)
  (assert_msg "check tuple recv" (is_a recv class_source_tuple) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (debug "normexp_tuple recv" recv)
  (let ( (sloc (unsafe_get_field :loca_location recv))
         (sargs (unsafe_get_field :sargop_args recv))
         (csymrec (clone_symbol 'tuplrec_))
         (csymtup (clone_symbol 'tuple_))
         (normdiscrmult (normal_predef discr_multiple ncx sloc "discr_multiple"))
         (newenv (fresh_env env))
         )
    (debug "normexp_tuple csymrec" csymrec)
    (multicall
     (nargs nbindings)
     (normalize_tuple sargs env ncx sloc)
     (debug "normexp_tuple nargs=" nargs " nbindings=" nbindings)
     ;; insight: normalize (tuple x1 x2) exactly as 
     ;; as an anonymous letrec
     (letrec (
               (constupbind (instance class_normal_constructed_tuple_binding
                                      :binder csymrec
                                      :nconsb_loc sloc
                                      :nconsb_discr normdiscrmult
                                      :nconsb_nletrec nletrec
                                      :ntupb_comp nargs
                                      ))
               (clocc (instance class_nrep_locsymocc
                                :nrep_loc sloc
                                :nocc_ctyp ctype_value
                                :nocc_symb csymrec
                                :nocc_bind constupbind))
               (tup1bind (tuple constupbind))
               (tup1loc (tuple clocc))
               (nbdy (tuple clocc))
               (nletrec (instance class_nrep_letrec
                                  :nrep_loc sloc
                                  :nlet_bindings tup1bind
                                  :nlet_body nbdy
                                  :nletrec_fill_bindings ()
                                  :nletrec_body_bindings ()
;; perhaps we should avoid having tup1loc to share the same location
;; for the letrec and the tuple result?
                                  :nletrec_locsyms tup1loc
                                  ))
               (ctupbind (instance class_normal_let_binding
                                   :binder csymtup
                                   :letbind_loc sloc
                                   :letbind_type ctype_value
                                   :letbind_expr nletrec))
               (ctuplocc (instance class_nrep_locsymocc
                                   :nrep_loc sloc
                                   :nocc_ctyp ctype_value
                                   :nocc_symb csymtup
                                   :nocc_bind ctupbind))
               (ctupbindlist (list ctupbind))
               )
             (if (null nbindings)
                 (setq nbindings ctupbindlist)
               (list_append nbindings ctupbind)
               )
             (debug "normexp_tuple ctupbind" ctupbind)
             (foreach_pair_component_in_list
              (nbindings)
              (curpair curbind)
              (put_env newenv curbind)
              )
             (foreach_in_multiple
              (nargs)
              (curnarg :long nix)
              (let ( (curctype (get_ctype curnarg newenv))
                     )
                (assert_msg "check curctype" (is_a curctype class_ctype))
              (when (!= curctype ctype_value)
                    (debug "normexp_tuple bad curnarg=" curnarg " of curctype=" curctype)
                    (error_at sloc "(TUPLE ...) argument #$1 should be value got $2" nix (get_field :named_name curctype))
                    (return)))
              )
             (debug "normexp_tuple return ctuplocc=" ctuplocc " nbindings=" nbindings)
             (return ctuplocc nbindings)
             )
     ;;
     )))
(install_method class_source_tuple normal_exp normexp_tuple)

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


(defun normexp_list (recv env ncx psloc)
  (assert_msg "check list recv" (is_a recv class_source_list) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (debug "normexp_list recv" recv)
  (let ( (sloc (or (unsafe_get_field :loca_location recv) psloc))
         (sargs (unsafe_get_field :sargop_args recv))
         (csymrec (clone_symbol 'listrec_))
         (csymlist (clone_symbol 'list_))
         (normdiscrpair (normal_predef discr_pair ncx sloc "discr_pair"))
         (normdiscrlist (normal_predef discr_pair ncx sloc "discr_list"))
         (newenv (fresh_env env))
         (:long nbargs (multiple_length sargs))
         (consbindtup (list_to_multiple (prepare_constructor_binding recv csymlist ncx sloc)))
         (resbindings (make_list discr_list))
         (conslistbind (multiple_nth consbindtup -1))
         (tuprecloc (multiple_map
                     consbindtup
                     (lambda (curbind :long bindix)
                       (debug "normexp_list curbind" curbind)
                       (assert_msg "check curbind" (is_a curbind class_normal_constructor_binding) curbind)
                       (instance class_nrep_locsymocc
                                 :nrep_loc (or  (get_field :nconsb_loc curbind) sloc)
                                 :nocc_ctyp ctype_value
                                 :nocc_symb (get_field :binder curbind)
                                 :nocc_bind curbind)
                       )
                     ))
         )
    (debug "normexp_list csymrec=" csymrec
           " consbindtup=" consbindtup " conslistbind=" conslistbind
           " tuprecloc=" tuprecloc)
    (assert_msg "check conslistbind" (is_a conslistbind class_normal_constructed_list_binding) conslistbind)
    (multicall
     (nargs nbindings)
     (normalize_tuple sargs env ncx sloc)
     (debug "normexp_list nargs=" nargs " nbindings=" nbindings)
     (assert_msg "check nbindings" (is_list_or_null nbindings) nbindings)
     (list_append2list resbindings nbindings)
     (foreach_pair_component_in_list
      (resbindings)
      (curpairbind curbind)
      (put_env newenv curbind)
      )
     (foreach_in_multiple
      (nargs)
      (curnarg :long nix)
      (if (!= (get_ctype curnarg newenv) ctype_value)
          (progn
            (debug "normexp_list bad curnarg" curnarg)
            (error_at sloc "(LIST ...) argument #$1 should be value" nix)
            (return))))
     (letrec (
              (creclocc (instance class_nrep_locsymocc
                                  :nrep_loc sloc
                                  :nocc_ctyp ctype_value
                                  :nocc_symb csymrec
                                  :nocc_bind conslistbind))
              (nbdy (tuple creclocc))
              (nletrec (instance class_nrep_letrec
                                 :nrep_loc sloc
                                 :nlet_bindings consbindtup
                                 :nlet_body nbdy
                                 :nletrec_fill_bindings ()
                                 :nletrec_body_bindings ()
                                 :nletrec_locsyms tuprecloc
                                 ))
              (clistbind (instance class_normal_let_binding
                                   :binder csymlist
                                   :letbind_loc sloc
                                   :letbind_type ctype_value
                                   :letbind_expr nletrec))
              (clistlocc (instance class_nrep_locsymocc
                                   :nrep_loc sloc
                                   :nocc_ctyp ctype_value
                                   :nocc_symb csymlist
                                   :nocc_bind clistbind))
              (clistbindlist (list clistbind))
              )
             (foreach_in_multiple
              (nargs)
              (curnarg :long nix)
              (let ( (curpairb (multiple_nth consbindtup nix)) 
                     (nextb (multiple_nth consbindtup (+i nix 1)))
                     )
                (put_int curpairb nix)
                (debug "normexp_list curpairb" curpairb)
                (assert_msg "check curpairb" (is_a curpairb class_normal_constructed_pair_binding) curpairb)
                (assert_msg "check curpairb objnum" (==i (get_int curpairb) nix) curpairb nix)
                (debug "normexp_list curnarg=" curnarg " nextb=" nextb)
                (assert_msg "check nextb" (is_a nextb class_normal_constructor_binding) nextb)
                (let ( (nextsym (get_field :binder nextb))
                       (nextloc (if (is_a nextb class_normal_constructed_pair_binding)
                                    (nreclist_find_locsym nextsym nletrec)))
                       )
                  (put_fields curpairb 
                              :npairb_head curnarg :npairb_tail nextloc
                              :nconsb_nletrec nletrec)
                  (debug "normexp_list updated curpairb" curpairb)
                  )
                ))
             ;;
             ;; update the list binding
             (let ( (firstpairb (multiple_nth consbindtup 0))
                    (lastpairb (multiple_nth consbindtup -2))
                    (firstpairsymb
                     (if 
                         (is_a firstpairb class_normal_constructed_pair_binding)
                         (unsafe_get_field :binder firstpairb)))
                    (lastpairsymb
                     (if 
                         (is_a lastpairb class_normal_constructed_pair_binding)
                         (unsafe_get_field :binder lastpairb)))
                    (firstpairloc 
                     (if firstpairsymb  
                         (nreclist_find_locsym firstpairsymb  nletrec)))
                    (lastpairloc 
                     (if lastpairsymb  
                         (nreclist_find_locsym lastpairsymb  nletrec)))
                   )
               (put_fields
                conslistbind
                :nlistb_first firstpairloc :nlistb_last lastpairloc
                :nconsb_nletrec nletrec)
               (put_int conslistbind nbargs)
               (debug "normexp_list updated conslistbind" conslistbind)
               )
             ;;
             (if (null nbindings)
                 (setq nbindings clistbindlist)
               (list_append nbindings clistbind)
               )
             (debug "normexp_list final nletrec=" nletrec
                    " clistlocc=" clistlocc " nbindings=" nbindings)
             (return clistlocc nbindings)
             ))))
(install_method class_source_list normal_exp normexp_list)
;;;;;;;;;;;;;;;;


(defun normexp_arithmetic_variadic_operation (recv env ncx psloc)
  (debug "normexp_arithmetic_variadic_operation recv" recv)
  (assert_msg "check recv" (is_a recv class_source_arithmetic_variadic_operation) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (or (unsafe_get_field :loca_location recv) psloc))
         (sargs (unsafe_get_field :sargop_args recv))
         (sneutral (unsafe_get_field :sarithvar_neutral recv))
         (sprimitive (unsafe_get_field :sarithvar_primitive recv))
         )
    (debug "normexp_arithmetic_variadic_operation sprimitive=" sprimitive " sneutral=" sneutral)
    (assert_msg "check sprimitive" (is_a sprimitive class_primitive) sprimitive)
    (assert_msg "check sneutral" (is_integerbox sneutral) sneutral)
    ;; actually, we normalize only to check the type here. We produce
    ;; a source primitive which is normalized again.
    (multicall
     (nargs nbindings)
     (normalize_tuple sargs env ncx sloc)
     (debug "normexp_arithmetic_variadic_operation nargs=" nargs " nbindings=" nbindings)
     (assert_msg "check nbindings" (is_list_or_null nbindings) nbindings)
     ;; check that all arguments are :long
     (foreach_in_multiple
      (nargs)
      (curnarg :long argix)
      (let ( (argctyp (get_ctype curnarg env))
             )
        (when (!= argctyp ctype_long)
          (error_at sloc "variadic arithmetic operation requires only :long arguments got $1 at #$2"_ (get_field :named_name argctyp) argix)
          (return))             
        ))
     (match
      sargs
      (?(tuple ?s0)
        (let ( (sprim (instance class_source_primitive
                                :loca_location sloc
                                :sprim_oper sprimitive
                                :sargop_args (tuple sneutral s0)))
               )
          (debug "normexp_arithmetic_variadic_operation unary sprim=" sprim)
          (multicall
           (nrealargs nrealbindings)
           (normexp_primitive sprim env ncx psloc)
           (debug "normexp_arithmetic_variadic_operation unary result nrealargs=" nrealargs 
                  " nrealbindings=" nrealbindings)
           (return nrealargs nrealbindings)
           (void)
           )))
      (?(tuple ?s0 ?s1)
        (let ( (sprim (instance class_source_primitive
                                :loca_location sloc
                                :sprim_oper sprimitive
                                :sargop_args (tuple s0 s1)))
               )
          (debug "normexp_arithmetic_variadic_operation binary sprim=" sprim)
          (multicall
           (nrealargs nrealbindings)
           (normexp_primitive sprim env ncx psloc)
           (debug "normexp_arithmetic_variadic_operation binary result nrealargs=" nrealargs 
                  " nrealbindings=" nrealbindings)
           (return nrealargs nrealbindings)
           (void)
           )))
      (?_
       (assert_msg "check #args>2" (>i (multiple_length sargs) 2) sargs)
       (let ( (sprim (instance class_source_primitive
                               :loca_location sloc
                               :sprim_oper sprimitive
                               :sargop_args (tuple (multiple_nth sargs 0) (multiple_nth sargs 1))))
              )
         (foreach_in_multiple
          (sargs)
          (cursarg :long six)
          (if (>i six 1)
              (let ( (newsprim (instance class_source_primitive
                                         :loca_location sloc
                                         :sprim_oper sprimitive
                                         :sargop_args (tuple sprim cursarg)))
                     )
                (setq sprim newsprim)))
          )
         (debug "normexp_arithmetic_variadic_operation nary sprim=" sprim)
         (multicall
          (nrealargs nrealbindings)
          (normexp_primitive sprim env ncx psloc)
          (debug "normexp_arithmetic_variadic_operation nary result nrealargs=" nrealargs 
                 " nrealbindings=" nrealbindings)
          (return nrealargs nrealbindings)
          (void)         
          )))
      ))))
(install_method class_source_arithmetic_variadic_operation normal_exp normexp_arithmetic_variadic_operation)

;;;;;;;;;;;;;;;;
(defselector prepare_constructor_binding class_selector
  :doc #{The $PREPARE_CONSTRUCTOR_BINDING selector applied to: an
  constructible expression $RECV, a symbol $SYMB, a normalization
  context $NCX, a source location $SLOC gives a half-filled instance
  of a sub-class of $CLASS_NORMAL_CONSTRUCTOR_BINDING.}#
  :formals (recv symb ncx sloc)
)

(defun badmeth_prepare_constructor_binding (recv symb ncx sloc)
  (debug "bad_prepare_constructor_binding recv=" recv " symb=" symb)
  (error_at sloc "invalid constructor binding $1 of receiver dicriminant $2"_
            (get_field :named_name symb)
            (get_field :named_name (discrim recv)))
  (assert_msg "@$@badmeth_prepare_constructor_binding" () recv symb)
)
(install_method discr_any_receiver prepare_constructor_binding badmeth_prepare_constructor_binding)


;;;;;;;;;;;;;;;;
(defselector normal_letrec_constructive class_selector
  :doc #{The $NORMAL_LETREC selector applied to: a constructive
  expression $CEXPR for receiver, a symbol $SYMB, a normal
  constructive binding $CBIND, an environment $ENV, a normal context
  $NCX, a location $SLOC}#
  :formals (cexpr symb cbind env ncx sloc))

(defun badmeth_normal_letrec_constructive (cexpr symb cbind env ncx sloc)
  (debug "badmeth_normal_letrec_constructive cexpr=" cexpr " symb=" symb
         " cbind=" cbind)
  (error_at sloc "invalid letrec constructive symbol $1 for reciever $2" 
            (get_field :named_name symb)
            (get_field :named_name (discrim cexpr)))
  (assert_msg "@$@badmeth_normal_letrec_constructive" () cexpr symb)
)
(install_method discr_any_receiver normal_letrec_constructive badmeth_normal_letrec_constructive)

;;;;;;;;;;;;;;;;
(defun prepcons_lambda (recv symb ncx sloc)
  (debug "prepcons_lambda recv=" recv " symb=" symb)
  (assert_msg "check recv" (is_a recv class_source_lambda) recv)
  (let  ( (conslam (instance class_normal_constructed_lambda_binding
                             :binder symb
                             :nconsb_loc sloc
                             :nconsb_discr (normal_predef discr_closure ncx sloc "discr_closure")
                             ))
          )
    (debug "prepcons_lambda gives conslam" conslam)
    (return conslam)
))
(install_method class_source_lambda prepare_constructor_binding prepcons_lambda)

;;;;


(defun normletrec_lambda  (cexpr symb cbind env ncx psloc)
  (debug "normletrec_lambda cexpr=" cexpr " symb=" symb
         " cbind=" cbind " env=" env)
  (assert_msg "check cbind" (is_a cbind class_normal_constructed_lambda_binding) cbind)
  (let ( (newenv (fresh_env env))
         )
    (debug "normletrec_lambda newenv" newenv)
    (assert_msg "check newenv" (is_a newenv class_environment) newenv)
    (multicall
     (nproc csym clocc constrout clovtup sloc oldproc ndatarout :long insideflag)
     ;;bad (normalize_lambda cexpr newenv newenv ncx psloc)
     (normalize_lambda cexpr env newenv ncx psloc)
     (debug "normletrec_lambda after normalize_lambda csym=" csym
            "\n.. clocc=" clocc
            "\n.. constrout=" constrout
            "\n.. clovtup=" clovtup
            "\n.. oldproc=" oldproc
            "\n.. ndatarout=" ndatarout
            "\n.. newenv=" newenv)
     (if insideflag
         (list_append (get_field :nrclop_constlist oldproc) ndatarout))
     (put_fields cbind 
                 :nlambdab_nclosed clovtup
                 :nlambdab_constrout constrout
                 :nlambdab_datarout ndatarout)
     (debug "normletrec_lambda updated cbind" cbind)
     (compile_warning "unimplemented normletrec_lambda, maybe store the newenv in the cbind")
     (shortbacktrace_dbg "normletrec_lambda ended" 15)
     )))
(install_method class_source_lambda normal_letrec_constructive normletrec_lambda)

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

(defun prepcons_tuple (recv symb ncx sloc)
  (debug "prepcons_tuple recv=" recv " symb=" symb)
  (assert_msg "check recv" (is_a recv class_source_tuple) recv)
  (let  ( 
         (loc (get_field :loca_location recv))
         (tuparg (get_field :sargop_args recv))
         (:long nbtuparg (multiple_length tuparg))
         (ntup (make_multiple discr_multiple nbtuparg))
         (constup (instance class_normal_constructed_tuple_binding
                             :binder symb
                             :nconsb_loc (or loc sloc)
                             :nconsb_discr (normal_predef discr_multiple ncx sloc "discr_multiple")
                             :ntupb_comp ntup
                             ))
          )
    (debug "prepcons_tuple gives constup" constup)
    (return constup)
))
(install_method class_source_tuple prepare_constructor_binding prepcons_tuple)
;;;;

(defun normletrec_tuple  (cexpr symb cbind env ncx sloc)
  (debug "normletrec_tuple cexpr=" cexpr " symb=" symb " cbind=" cbind)
  (assert_msg "check cexpr" (is_a cexpr class_source_tuple) cexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check cbind" (is_a cbind class_normal_constructed_tuple_binding) cbind)
  (let ( 
        (loc (or (get_field :loca_location cexpr) sloc))
        (sargs (unsafe_get_field :sargop_args cexpr))
        (bcomp (get_field :ntupb_comp cbind))
        (nletrec (get_field :nconsb_nletrec cbind))
        (nrecbinds (get_field :nletrec_fill_bindings nletrec))
        )
    (debug "normletrec_tuple sargs=" sargs " bcomp=" bcomp
           " nletrec=" nletrec " nrecbinds=" nrecbinds)
    (assert_msg "check nletrec" (is_a nletrec class_nrep_letrec) nletrec)
    (assert_msg "check nrecbinds" (is_list nrecbinds) nrecbinds)
    (multicall
     (nargs nbinds)
     (normalize_tuple sargs env ncx loc)
     (debug "normletrec_tuple nargs=" nargs " nbinds=" nbinds)
     (assert_msg "check nargs & bcomp samelength" (==i (multiple_length bcomp) (multiple_length nargs)) nargs bcomp)
     (assert_msg "check nbinds" (is_list_or_null nbinds) nbinds)
     (foreach_in_multiple 
      (nargs)
      (curnarg :long nix)
      (multiple_put_nth bcomp nix curnarg))
     (debug "normletrec_tuple updated bcomp" bcomp)
     (list_append2list nrecbinds nbinds)
     (debug "normletrec_tuple updated nrecbinds" nrecbinds)
     (shortbacktrace_dbg "normletrec_tuple ended" 15)
     )))
(install_method class_source_tuple normal_letrec_constructive normletrec_tuple)

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

(defun prepcons_list (recv symb ncx sloc)
  (debug "prepcons_list recv=" recv " symb=" symb)
  (assert_msg "check recv" (is_a recv class_source_list) recv)
  (let  ( 
         (reslist (make_list discr_list))
         (loc (get_field :loca_location recv))
         (listarg (get_field :sargop_args recv))
         (:long nblistarg (multiple_length listarg))
         (pairsb (make_multiple discr_multiple nblistarg))
         (conslist (instance class_normal_constructed_list_binding
                             :binder symb
                             :nconsb_loc (or loc sloc)
                             :nconsb_discr (normal_predef discr_list ncx sloc "discr_list")
                             :nlistb_first () 
                             :nlistb_last ()
                             :nlistb_pairsb pairsb
                             ))
          )
    (foreach_in_multiple 
     (listarg)
     (curarg :long curix)
     (debug "prepcons_list curarg" curarg)
     (let ( (pairsymb (clone_symbol (if (is_a curarg class_named) curarg '_pairoflist)))
            (conspair (instance class_normal_constructed_pair_binding
                                :binder pairsymb
                                :nconsb_loc (or (get_field :loca_location curarg) loc sloc)
                                :nconsb_discr (normal_predef discr_pair ncx sloc "discr_pair")
                                :npairb_head ()
                                :npairb_tail ()
                                ))
            )
       (multiple_put_nth pairsb curix conspair)
       (list_append reslist conspair)
     ))
    (list_append reslist conslist)
    (debug "prepcons_list gives reslist" reslist)
    (return reslist)
))
(install_method class_source_list prepare_constructor_binding prepcons_list)
;;;;


;; auxiliary function to find a symbol in the locsym of a nletrec
(defun nreclist_find_locsym (symb nletrec)
  (debug "nreclist_find_locsym symb=" symb)
  (assert_msg "check symb" (is_a symb class_symbol) symb)
  (assert_msg "check nletrec" (is_a nletrec class_nrep_letrec) nletrec)
  (let ( (nlocsyms (get_field :nletrec_locsyms nletrec)) 
         )
    (foreach_in_multiple
     (nlocsyms)
     (curlocsym :long locsymix)
     (if (== (get_field :nocc_symb curlocsym) symb)
         (progn
           (debug "nreclist_find_locsym found curlocsym" curlocsym)
           (return curlocsym))))
    (debug "nreclist_find_locsym not found")
    (return)
    ))


(defun normletrec_list (cexpr symb cbind env ncx sloc)
  (debug "normletrec_list cexpr=" cexpr " symb=" symb " cbind=" cbind)
  (assert_msg "check cexpr" (is_a cexpr class_source_list) cexpr)
  ;; here cbind is a tuple of constructor bindings -for all the pairs
  ;; & the list
  (assert_msg "check cbind is tuple" (is_multiple cbind) cbind)
  (let ( (loc (or (get_field :loca_location cexpr) sloc))
         (sargs (get_field :sargop_args cexpr))
         (conslibind (multiple_nth cbind -1))
         (nletrec (get_field :nconsb_nletrec conslibind))
         (nrecbinds (get_field :nletrec_fill_bindings nletrec))
         (nlocsyms (get_field :nletrec_locsyms nletrec))
         (firstpairbind (multiple_nth cbind 0))
         (lastpairbind (multiple_nth cbind -2))
         )
    (debug "normletrec_list conslibind" conslibind)
    (assert_msg "check conslibind"
                (is_a conslibind class_normal_constructed_list_binding)
                conslibind)
    (debug "normletrec_list sargs=" sargs
           " nletrec=" nletrec " nrecbinds=" nrecbinds)
    (assert_msg "check nletrec" (is_a nletrec class_nrep_letrec) nletrec)
    (assert_msg "check nrecbinds" (is_list nrecbinds) nrecbinds)
    (multicall
     (nargs nbinds)
     (normalize_tuple sargs env ncx loc)
     (debug "normletrec_list nargs=" nargs " nbinds=" nbinds)
     (assert_msg "check nbinds" (is_list_or_null nbinds) nbinds)
     (assert_msg "check nargs's length vs cbind's length"
                 (==i (multiple_length nargs) (-i (multiple_length cbind) 1))
                 nargs cbind)
     (foreach_in_multiple
      (nargs)
      (curnarg :long nix)
      (debug "normletrec_list curnarg" curnarg)
      (let ( (curcbind  (multiple_nth cbind nix)) 
             (nextcbind  (multiple_nth cbind (+i 1 nix)))
             (nextpairsymb (if (is_a nextcbind class_normal_constructed_pair_binding)
                               (get_field :binder nextcbind)))
             )
        (debug "normletrec_list curcbind=" curcbind " nextcbind=" nextcbind
               " nextpairsymb=" nextpairsymb)
        (assert_msg "check curcbind" (is_a curcbind class_normal_constructed_pair_binding) curcbind)
        (let ( (nextpairloc     (if nextpairsymb (nreclist_find_locsym nextpairsymb nletrec))) )
          (debug "normletrec_list got nextpairloc" nextpairloc)
          (put_fields curcbind
                      :npairb_head curnarg
                      :npairb_tail nextpairloc)
          (debug "normletrec_list updated curcbind" curcbind)
          (assert_msg "check curcbind" (is_a curcbind class_normal_constructed_pair_binding) curcbind)
          )))
     (debug "normletrec_list firstpairbind=" firstpairbind
            " lastpairbind=" lastpairbind
            " conslibind=" conslibind)
     (and (is_a firstpairbind class_normal_constructed_pair_binding)
          (is_a lastpairbind class_normal_constructed_pair_binding)
          (let ( (firstpairsymb (get_field :binder firstpairbind))
                 (lastpairsymb (get_field :binder lastpairbind))
                 (firstpairlocsy (nreclist_find_locsym firstpairsymb nletrec))
                 (lastpairlocsy (nreclist_find_locsym lastpairsymb nletrec))
                 )
            (debug "normletrec_list firstpairlocsy=" firstpairlocsy " lastpairlocsy=" lastpairlocsy)
            (put_fields conslibind
                        :nlistb_first firstpairlocsy
                        :nlistb_last lastpairlocsy)
            (debug "normletrec_list updated conslibind" conslibind)
            (void)
            ))
     (debug "normletrec_list appending nbinds" nbinds)
     (list_append2list nrecbinds nbinds)
     (debug "normletrec_list ended updated nrecbinds" nrecbinds)
     )))
(install_method class_source_list normal_letrec_constructive normletrec_list)


;;;;;;;;;;;;;;;;
(defun prepcons_instance (recv symb ncx sloc)
  (debug "prepcons_instance recv=" recv " symb=" symb)
  (assert_msg "check recv" (is_a recv class_source_instance) recv)
  (let  ( 
         (loc (get_field :loca_location recv))
         (cla (get_field :smins_class recv))
         (clabind (get_field :smins_clabind recv))
         (sclasym (if (is_a clabind class_any_binding) (unsafe_get_field :binder clabind)))
         (:long nbclafld (multiple_length (get_field :class_fields cla)))
         (tupslot (make_multiple discr_multiple nbclafld))
         (consinst (instance class_normal_constructed_instance_binding
                                :binder symb
                                :nconsb_loc (or loc sloc)
                                :nconsb_discr (compile_warning "don't forget to set the discr later...")
                                :ninstb_slots tupslot
                                :ninstb_clabind clabind
                                ))
         )
    (assert_msg "prepcons_instance check class" (is_a cla class_class) cla)
    (debug "prepcons_instance gives consinst" consinst)
    (return consinst)
    )
  )
(install_method class_source_instance prepare_constructor_binding prepcons_instance)

;;;;

(defun normletrec_instance  (cexpr symb cbind env ncx sloc)
  (debug "normletrec_instance cexpr=" cexpr " symb=" symb " cbind=" cbind)
  (let ( (loc (or (unsafe_get_field :loca_location cexpr) sloc))
         (bslots (get_field :ninstb_slots cbind))
         (nletrec (get_field :nconsb_nletrec cbind))
         (nrecbinds (get_field :nletrec_fill_bindings nletrec))
         (sclass (unsafe_get_field :smins_class cexpr))
         (sclabind (unsafe_get_field :smins_clabind cexpr))
         (sfields (unsafe_get_field :smins_fields cexpr))
         (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 "normletrec_instance nletrec" nletrec)
    (when (not (is_a cladata class_nrep))
      (error_at sloc "invalid class in (INSTANCE $1 ...)" (unsafe_get_field :named_name sclass))
      (return ()))
    (let ( (nfields 
            (multiple_map 
             sfields 
             (lambda (curflda :long curk)
               (assert_msg "check curflda" (is_a curflda class_source_fieldassign) curflda)
               (let ( (curfloc (unsafe_get_field :loca_location 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)
                  (debug "normletrec_instance nexp" nexp)
                  (assert_msg "check nbind" (is_list_or_null nbind) nbind)
                  (list_append2list bindlist  nbind)
                  (instance class_nrep_fieldassign
                            :nrep_loc curfloc
                            :nfla_field curfield
                            :nfla_val nexp)
                  )))))
           )
      (debug "normletrec_instance nfields" nfields)
      (foreach_in_multiple
       (nfields)
       (curnfieldass :long fldix)
       (debug "normletrec_instance curnfieldass" curnfieldass)
       (let ( (curfield (get_field :nfla_field curnfieldass)) 
              (curfval (get_field :nfla_val curnfieldass))
              (curfloc (get_field :nrep_loc curnfieldass))
              (:long curfoff (get_int curfield))
              )
         (assert_msg "check curfield " (is_a curfield class_field) curfield)
         (let ( (fctyp (get_ctype curfval env))
                )
           (if (!= fctyp ctype_value)
               (error_at
                curfloc 
                "invalid field $1 type in (LETREC .. (INSTANCE ..); expecting a :value gotten a $2"_
                (get_field :named_name curfield)
                (get_field :named_name fctyp))))
         (multiple_put_nth bslots curfoff curfval)
       ))
      (list_append2list nrecbinds bindlist)
      (debug "normletrec_instance ended updated nrecbinds" nrecbinds)
      )
    ))
(install_method class_source_instance normal_letrec_constructive normletrec_instance)



;;;;;;;;;;;;;;;;
(defun normexp_letrec (recv env ncx psloc)
  (assert_msg "check letrec recv" (is_a recv class_source_letrec) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (debug "normexp_letrec recv" recv)
  (let ( (sloc (unsafe_get_field :loca_location recv))
         (sbinds (unsafe_get_field :slet_bindings recv))
         (sbody (unsafe_get_field :slet_body recv))
         (:long nbbind (multiple_length sbinds))
         (bindlist (make_list discr_list))
         (consbindlist (make_list discr_list))
         (newenv (fresh_env env))
         (:long maplen (+i 5 (*i nbbind 2)))
         (symbexprmap (make_mapobject discr_map_objects maplen))
         (symbindmap (make_mapobject discr_map_objects maplen))
         )
;;; first preparation loop
    (foreach_in_multiple
     (sbinds)
     (cursbind :long sbix)
     (debug "normexp_letrec cursbind" cursbind)
     (assert_msg "check cursbind" (is_a cursbind class_source_letrec_binding) cursbind)
     (let ( (locb (or (unsafe_get_field :loca_location cursbind) sloc psloc))
            (cursymb (unsafe_get_field :sletb_binder cursbind))
            (curexpr (unsafe_get_field :sletb_expr cursbind))
            )
       (debug "normexp_letrec curexpr=" curexpr " cursymb=" cursymb)
       (assert_msg "check curexpr" (is_a curexpr class_source) curexpr)
       (assert_msg "check cursymb" (is_a cursymb class_symbol) cursymb)
       (mapobject_put symbexprmap cursymb curexpr)
       (let ( (curconsbind (prepare_constructor_binding curexpr cursymb ncx locb))
              )
         (debug "normexp_letrec curconsbind" curconsbind)
         (cond ( (is_a curconsbind class_normal_constructor_binding)
                 (debug "normexp_letrec curconsbind plain consbind" curconsbind)
                 (list_append consbindlist curconsbind)
                 (mapobject_put symbindmap cursymb curconsbind)
                 )
               ( (is_multiple curconsbind)
                 (debug "normexp_letrec curconsbind multiple" curconsbind)
                 (foreach_in_multiple 
                  (curconsbind)
                  (subconsbind :long subix)
                  (assert_msg "normexp_letrec check subconsbind" 
                              (is_a subconsbind class_normal_constructor_binding)
                              subconsbind)
                  (list_append consbindlist subconsbind))
                 (mapobject_put symbindmap cursymb curconsbind)
                 )
               ( (is_list curconsbind)
                 (debug "normexp_letrec curconsbind list" curconsbind)
                 (foreach_pair_component_in_list
                  (curconsbind)
                  (subconspair subconsbind)
                  (assert_msg "normexp_letrec check subconsbind" 
                              (is_a subconsbind class_normal_constructor_binding)
                              subconsbind)
                  (list_append consbindlist subconsbind))
                 (mapobject_put symbindmap cursymb (list_to_multiple curconsbind discr_multiple))
                 )
               (:else
                (assert_msg "normexp_letrec bad curconsbind" () curconsbind)
                ))
         )
       )
     )
    (debug "normexp_letrec consbindlist" consbindlist)
    (let (
          (:long nbconsbind (list_length consbindlist))
          (:long curcix 0)
          (nlocsyms (make_multiple discr_multiple nbconsbind))
          (ncbindtup (make_multiple discr_multiple nbconsbind))
          (recfillbindings (make_list discr_list))
          (nletrec (instance class_nrep_letrec
                             :nrep_loc sloc
                             :nlet_bindings ncbindtup
                             :nletrec_fill_bindings recfillbindings 
                             :nletrec_locsyms nlocsyms 
                             ;; nlet_body & nletrec_body_bindings is set after
                             :nlet_body ()
                             :nletrec_body_bindings ()
                             )) 
          )
      (debug "normexp_letrec unfilled nletrec" nletrec)
      ;;
      ;; second loop to make an environment where each constructive
      ;; binding is set, and to create the local symbol occurrences
      (foreach_pair_component_in_list
       (consbindlist)
       (curpair curcbind)
       (debug "normexp_letrec curcbind" curcbind)
       (assert_msg "check curcbind" (is_a curcbind class_normal_constructor_binding) curcbind)
       (multiple_put_nth ncbindtup curcix curcbind)
       (put_int curcbind curcix)
       (put_fields curcbind :nconsb_nletrec nletrec)
       (let ( (curbdiscr (unsafe_get_field :nconsb_discr curcbind)) 
              (curbinder (unsafe_get_field :binder curcbind))
              (nlocsym (instance class_nrep_locsymocc
                                 :nrep_loc (or (get_field :nconsb_loc curcbind) 
                                               sloc psloc)
                                 :nocc_ctyp ctype_value
                                 :nocc_symb curbinder
                                 :nocc_bind curcbind
                        ))
              )
         (multiple_put_nth nlocsyms curcix nlocsym)
         (if (null curbdiscr)
             (let ( (clabind (get_field :ninstb_clabind curcbind))
                    (clasym (get_field :binder clabind))
                    )
               (debug "normexp_letrec clabind=" clabind " clasym=" clasym)
               ;; the only case when this happens is for instance constructors...
               (assert_msg "check curcbind for instance" (is_a curcbind class_normal_constructed_instance_binding) curcbind)
               (let ( ;; we normalize the class symbol in the parent environment, not the new one! 
                     (cladata (normal_exp clasym env ncx sloc)) 
                     )
                 (debug "normexp_letrec cladata" cladata)
                 (assert_msg "check cladata" (is_a cladata class_nrep) cladata)
                 (put_fields curcbind :nconsb_discr cladata)
                 )))
         )
       (setq curcix (+i curcix 1))
       (put_env newenv curcbind)
       (compile_warning "normexp_letrec should normalize the expression using symbexprmap & curbinder...")
       )
;;; third loop to normalize the bindings content
      (foreach_in_multiple
       (sbinds)
       (cursbind :long sbix)
       (debug "normexp_letrec thirdloop cursbind=" cursbind " sbix=" sbix)
       (assert_msg "check cursbind" (is_a cursbind class_source_letrec_binding) cursbind)
       (let ( (locb (or (unsafe_get_field :loca_location cursbind) sloc psloc))
              (cursymb (unsafe_get_field :sletb_binder cursbind))
              (curexpr (unsafe_get_field :sletb_expr cursbind))
              (curbind (mapobject_get symbindmap cursymb))
              (cursexpr (mapobject_get symbexprmap cursymb))
              )
         (debug "normexp_letrec thirdloop curexpr=" curexpr
                " cursymb=" cursymb
                " curbind=" curbind
                " cursexpr=" cursexpr)
         (assert_msg "check curxpr same cursexpr" (== curexpr cursexpr) cursexpr cursexpr)
         (normal_letrec_constructive curexpr cursymb curbind newenv ncx sloc)
         (debug "normexp_letrec thirdloop done curexpr" curexpr)
         )
       )
      (debug "normexp_letrec recfillbindings before normalizing the body" recfillbindings)
;;;
;;; normalize the body
      (debug "normexp_letrec normalizing sbody" sbody)
      (multicall
       (nbody nbodbindings)
       (normalize_tuple sbody newenv ncx sloc)
       (debug "normexp_letrec nbody=" nbody " nbodbindings=" nbodbindings)
       (assert_msg "normexp_letrec check nbodbindings" (is_list_or_null nbodbindings) nbodbindings)
       (put_fields nletrec 
                   :nlet_body nbody
                   :nletrec_body_bindings nbodbindings)
       (debug "normexp_letrec updated nletrec" nletrec)
       (assert_msg "normexp_letrec check bindlist" (is_list_or_null bindlist) bindlist)
;;; remove every locally bound symbol from the symbol cache map
       (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx)) )
         (foreach_pair_component_in_list
          (bindlist)
          (curpair bnd)
          (debug "normexp_letrec removing from sycmap bnd" bnd)
          (assert_msg "normexp_letrec check bnd" (is_a bnd class_normal_let_binding) bnd)
          (mapobject_remove sycmap (unsafe_get_field :binder bnd))
          ))
;;;; make the result
       (let (
             (nlastbody (multiple_nth nbody -1))
             ;; the type of a let with empty body is void
             (nlastyp (or (get_ctype nlastbody newenv) ctype_void))
             (csym (clone_symbol 'letrec_))
             (cbind (instance class_normal_let_binding
                              :binder csym
                              :letbind_loc sloc
                              :letbind_type nlastyp
                              :letbind_expr nletrec))
             (clocc (instance class_nrep_locsymocc
                              :nrep_loc sloc
                              :nocc_ctyp nlastyp
                              :nocc_bind cbind))
             (resbinds (make_list discr_list))
             )
         (list_append resbinds cbind)
         (debug "normexp_letrec result clocc=" clocc 
                " nletrec=" nletrec " resbinds=" resbinds)
         (shortbacktrace_dbg "normexp_letrec ending" 15)
         (return clocc resbinds)
         )))))
(install_method class_source_letrec normal_exp normexp_letrec)



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

;;; create the normal predef (or fail with a msg) 
(defun normal_predef (pred ncx sloc :cstring predname)
  (debug "normal_predef pred=" pred)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (predefmap (unsafe_get_field :nctx_predefmap ncx)) 
         (brk (or (mapobject_get predefmap pred)
                  (get_raw_symbol predname)))
         )
    (debug "normal_predef brk=" brk)
    (if (or (is_integerbox brk) (is_a brk class_symbol))
        (let ( (res (instance class_nrep_predef
                            :nrep_loc sloc
                            :nrpredef brk))
               )
          (debug "normal_predef res=" res)
          (return res))
      (progn
        (debug "normalpredef fail predefmap=" predefmap " pred=" pred)
        (error_at sloc "not a predef: $1" (make_stringconst discr_verbatim_string predname))
        (return ())
        ))))


;; 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!)
  (debug "normal_symbol_data start sym=" sym)
  (shortbacktrace_dbg "normal_symbol_data" 12)
  (assert_msg "check sym" (== (discrim sym) class_symbol) sym)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (valmap  (unsafe_get_field :nctx_valmap ncx))
         (osydata (mapobject_get valmap sym)) )
    (debug "normal_symbol_data osydata=" osydata)
    (when osydata
      (debug "normal_symbol_data found osydata" osydata)
      (return osydata))
    (let ( (:long syhash (obj_hash sym))
           (synamstr (unsafe_get_field :named_name sym))
           ;; make the datastring from synamstr
           (synamstrdata 
            (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 (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))
           )
      (debug "normal_symbol_data sydata=" sydata "\n.. synamstrdata=" synamstrdata)
      (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)
      (debug "normal_symbol_data return sydata" sydata)
      (return 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!)
  (debug "normal_keyword_data keyw=" keyw)
  (assert_msg "check keywb" (== (discrim keyw) class_keyword) keyw)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (valmap  (unsafe_get_field :nctx_valmap ncx))
         (osydata (mapobject_get valmap keyw)) )
    (if osydata osydata
      (let ( (:long syhash (obj_hash keyw))
             (synamstr (unsafe_get_field :named_name keyw))
             ;; make the datastring from synamstr
             (synamstrdata 
              (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 (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))
             )
        (shortbacktrace_dbg "normal_keyword_data" 15)
        (debug "normal_keyword_data sydata=" sydata "\n ..keyw=" keyw)
        (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)
        (debug "normal_keyword_data return sydata=" sydata)
        (return 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) cla) 
  (debug "create_data_slots cla" cla)
  (let ( (tupslo 
          (make_multiple discr_multiple  (multiple_length (unsafe_get_field :class_fields cla)))) 
         )
    (debug "create_data_slots tupslo" tupslo)
    tupslo
    ))

;; fill a slot of a datainstance
(defun fill_data_slot (di field val)
  (assert_msg "check di" (is_a di class_nrep_datainstance) di)
  (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, string or integer

(defun normexp_quote (recv env ncx psloc)
  (debug "normexp_quote recv=" recv)
  (assert_msg "check quote recv" (is_a recv class_source_quote) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (shortbacktrace_dbg "normexp_quote" 16)
  (let ( (sloc   (unsafe_get_field :loca_location recv))
         (quoted (unsafe_get_field :squoted recv)) 
         (curproc (unsafe_get_field :nctx_curproc ncx))
         (ndata 
          (cond
           ( (== (discrim quoted) class_symbol)
             (debug "normexp_quote symbol quoted=" quoted)
             (normal_symbol_data quoted ncx psloc))
           ( (is_integerbox quoted)
             (debug "normexp_quote integer quoted=" quoted)
             (let (
                   (nintdata (instance class_nrep_databoxedinteger
                                       :ndata_discrx (normal_predef discr_constant_integer ncx sloc "discr_constant_integer") 
                                       :nboxint_num quoted))
                   )
               (debug "normexp_quote nintdata=" nintdata)
               (add_nctx_data ncx nintdata)
               nintdata
               ))
           ( (is_string quoted)
             (debug "normexp_quote string quoted=" quoted)
             (let ( (nstrdata 
                     (instance class_nrep_datastring
                               :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
                               :nstr_string quoted))
                    )
               (debug "normexp_quote nstrdata=" nstrdata)
               (add_nctx_data ncx nstrdata)
               nstrdata))
           (:else
            ;; this should not happen, because it is checked at
            ;; macroexpansion time.
            (assert_msg "unexpected quoted stuff" () quoted))

           ))
         )
    (debug "normexp_quote ndata=" ndata "\n.. curproc=" curproc)
    (if (is_a curproc class_nrep_closproc)
        (let ( 
              (nconst (instance class_nrep_constant
                                :nrep_loc sloc
                                :nconst_sval quoted
                                :nconst_data ndata
                                :nconst_proc curproc
                                )) )
          (list_append (get_field :nrclop_constlist curproc) ndata)
          (debug "normexp_quote in routine nconst=" nconst)
          (return nconst ()))
      (progn
        (debug "normexp_quote in init ndata=" ndata)
        (return ndata ())
        ))))
(install_method class_source_quote normal_exp normexp_quote)


;;;;;; normalize a COMMENT
(defun normexp_comment (recv env ncx psloc)
  (debug "normexp_comment start recv" recv)
  (assert_msg "check comment recv" (is_a recv class_source_comment) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (unsafe_get_field :loca_location recv))
         (scomm (unsafe_get_field :scomm_str recv))
         (ncomm (instance class_nrep_comment
                          :nrep_loc sloc
                          :ncomm_string scomm
                          ))  
         (csym (clone_symbol 'comment_)) 
         (cbind (instance class_normal_let_binding
                          :letbind_loc sloc
                          :binder csym
                          :letbind_type ctype_void
                          :letbind_expr ncomm))
         (clocc (instance class_nrep_locsymocc
                          :nrep_loc sloc
                          :nocc_ctyp ctype_void
                          :nocc_symb csym
                          :nocc_bind cbind))
         (bindlist (make_list discr_list))
         )
    (if scomm (assert_msg "check scomm" (is_string scomm) scomm))
    (list_append bindlist cbind)
    (debug "normexp_comment end ncomm=" ncomm
           " return clocc=" clocc " bindlist=" bindlist)
    (return clocc bindlist)
    ))
(install_method class_source_comment normal_exp normexp_comment)


;;;;;; normalize a keyword
(defun normexp_keyword (recv env ncx psloc)
  (debug "normexp_keyword recv=" recv)
  (shortbacktrace_dbg "normexp_keyword" 10)
  (assert_msg "check keyword recv" (is_a recv class_keyword) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (curproc (unsafe_get_field :nctx_curproc ncx)) 
         (constlist (get_field :nrclop_constlist curproc))
         (objconstmap (get_field :nrclop_objconstcachemap curproc))
         (cacheres (mapobject_get objconstmap recv))
         )
    (when cacheres
      (debug "normexp_keyword return cacheres=" cacheres)
      (return cacheres ()))
    (let (
          (kdata (normal_keyword_data recv ncx psloc)) 
          )
      (debug "normexp_keyword kdata=" kdata "\n.. curproc=" curproc)
      (assert_msg "check curproc" (is_a curproc class_nrep_anyproc) curproc)
      (if (is_a curproc class_nrep_closproc)
          (let (
                (nconst (instance class_nrep_constant
                                  :nrep_loc psloc
                                  :nconst_sval recv
                                  :nconst_data kdata
                                  :nconst_proc curproc))
                )
            (debug "normexp_keyword closproc curproc=" curproc
                   "\n.. adding const kdata=" kdata)
            (list_append constlist kdata)
            (mapobject_put objconstmap recv nconst)
            (debug "normexp_keyword updated constlist=" constlist 
                   "\n.. objconstmap=" objconstmap)
            (debug "normexp_keyword result nconst=" nconst)
            (return nconst ())
            )
        (progn
          (debug "normexp_keyword routineinit result kdata=" kdata)
          (return kdata ())
          )))))
(install_method class_keyword normal_exp normexp_keyword)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; utilities for normalization of DEFPRIMITIVE & DEFCITERATOR
;;;; fill the normal single formal bind
(defun fill_normal_formalbind (fargb formsymbmap env ncx sloc)
  (assert_msg "check fargb" (is_a fargb class_formal_binding) fargb)
  (let ( (ftyp (unsafe_get_field :fbind_type fargb)) 
         (fsymb (unsafe_get_field :binder fargb))
         (fdataslot (create_data_slots class_formal_binding))
         (fargdata 
          (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
           ))
         (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) ftyp)
    (add_nctx_data ncx fargdata)
    (fill_data_slot fargdata binder fsymbdata)
    (fill_data_slot fargdata fbind_type ftypdata)
    (mapobject_put formsymbmap fsymb fargdata)
    (return fargdata)
    ))

;;;; fill the normal formal args
(defun fill_normal_formals (sargs nargtuple formsymbmap env ncx sloc)
  (foreach_in_multiple
   (sargs)
   (fargb :long ix)
   (let ( (fargdata (fill_normal_formalbind fargb formsymbmap env ncx sloc))
          )
     (assert_msg "check fargdata" (is_a fargdata class_nrep_datainstance) fargdata)
     (unsafe_put_fields fargdata
                        :ninst_objnum (make_integerbox discr_integer ix))
     (multiple_put_nth nargtuple ix fargdata)
     )))

;;;; fill the normal expansion for primitive etc...
(defun fill_normal_expansion (sexp nexptuple ncx sloc)
  (multiple_every
   sexp
   (lambda (expcomp :long ix)
     (let ( (discrcomp (discrim expcomp)) 
            (compdata 
             (cond ( (== discrcomp discr_verbatim_string)
                     (add_nctx_data ncx
                                    (instance 
                                     class_nrep_datastring
                                     :ndata_discrx (normal_predef discr_verbatim_string ncx sloc "discr_verbatim_string") 
                                     :nstr_string expcomp
                                     )))
                   ( (== discrcomp class_symbol)
                     (normal_symbol_data expcomp ncx sloc)
                     )
                   ( :else 
                     (debug "bad component in C code expansion expcomp" expcomp)
                     (error_at sloc "unexpected component #$1 of dicriminant $2 in C code expansion" ix (get_field :named_name discrcomp)))))
            )
       (multiple_put_nth nexptuple ix compdata)
       )))
  )

;;;;;; normalize a DEFPRIMITIVE
(defun normexp_defprimitive (recv env ncx psloc)
  (debug "normexp_defprimitive recv=" recv)
  (assert_msg "check defprimitive recv" (is_a recv class_source_defprimitive) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc   (unsafe_get_field :loca_location 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 (instance class_nrep_datatuple
                             :nrep_loc sloc
                             :ndata_name sname
                             :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple")
                             :ntup_comp nexptuple))
         (nargdata (instance class_nrep_datatuple
                             :nrep_loc sloc
                             :ndata_name sname
                             :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple")
                             :ntup_comp nargtuple))
         (nprimdata (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_map_objects (+i 3 (*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
    (fill_normal_formals sargs nargtuple formsymbmap env ncx sloc)
    ;; fill the expansion of the data
    (fill_normal_expansion sexp nexptuple ncx sloc)
;;; fill the primitive data    
    (fill_data_slot nprimdata named_name 
                    (add_nctx_data 
                     ncx
                     (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)
    (fill_data_slot nprimdata prim_type
                    (normal_predef stype ncx sloc "primitive res type"))
;;; put the data into the primitive binding
    (if (is_a sprimbind class_primitive_binding)
        (put_fields sprimbind  :fixbind_data nprimdata))
    (return () ())                   ;normalized defprimitive is empty
    ))
(install_method class_source_defprimitive normal_exp normexp_defprimitive)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a DEFCITERATOR
(defun normexp_defciterator (recv env ncx psloc)
  (debug "normexp_defciterator recv=" recv)
  (assert_msg "check defciterator recv" (is_a recv class_source_defciterator) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( 
        (sloc (unsafe_get_field :loca_location recv))
        (sname (unsafe_get_field :sdef_name recv))
        (sciter (let ( (sc (unsafe_get_field :sciterdef_citerator recv)) )
                  (assert_msg "check sciter" (is_a sc class_citerator) sc)
                  sc))
        (citbind (find_env env sname))
        (citstafor (unsafe_get_field :citer_start_formals sciter))
        (slotup (make_multiple discr_multiple
                               (multiple_length (unsafe_get_field :class_fields class_citerator))))
        (formstatup (make_multiple discr_multiple
                                   (multiple_length citstafor)))
        (citbodfor (unsafe_get_field :citer_body_formals sciter))
        (formbodtup (make_multiple discr_multiple 
                                   (multiple_length citbodfor)))
        (citstatsy (unsafe_get_field :citer_state sciter))
        (citexpbef (unsafe_get_field :citer_expbefore sciter))
        (expbeftup (make_multiple discr_multiple (multiple_length citexpbef)))
        (citexpaft (unsafe_get_field :citer_expafter sciter))
        (expafttup (make_multiple discr_multiple (multiple_length citexpaft)))
        ;; map of formal symbol -> data of formal_binding
        (formsymbmap (make_mapobject discr_map_objects
                                     (+i 5 (*i (+i (multiple_length citstafor) (multiple_length citbodfor)) 2))))
        (namstrdata (instance class_nrep_datastring
                              :nrep_loc sloc
                              :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
                              :nstr_string (unsafe_get_field :named_name sname)))
        (insdata (instance class_nrep_datainstance
                           :nrep_loc sloc
                           :ndata_name sname
                           :ndata_discrx (normal_predef class_citerator ncx sloc "class_citerator") 
                           :ninst_hash (make_integerbox discr_integer (nonzero_hash))
                           :ninst_slots slotup
                           )) 
        )
    (add_nctx_data ncx insdata)
    (add_nctx_data ncx namstrdata)
;;; fill the named_name of insdata
    (multiple_put_nth slotup (get_int named_name) namstrdata)
;;; fill the citer_start_formals of insdata
    (fill_normal_formals citstafor formstatup formsymbmap env ncx sloc)
    (let ( (nstatupdata (instance class_nrep_datatuple
                                  :nrep_loc sloc
                                  :ndata_name sname
                                  :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple")
                                  :ntup_comp formstatup))
           )
      (add_nctx_data ncx nstatupdata)
      (multiple_put_nth slotup (get_int citer_start_formals) 
                        nstatupdata)
      )
;;; fill the citer_state
    (assert_msg "check citstatsy" (is_a citstatsy class_symbol) citstatsy)
    (let ( (nstatsydata (normal_symbol_data citstatsy ncx sloc)) )
      (multiple_put_nth slotup (get_int citer_state) 
                        nstatsydata)
      )
;;; fill the citer_body_formals of insdata
    (fill_normal_formals citbodfor formbodtup formsymbmap env ncx sloc)
    (let ( (nbodtupdata (instance class_nrep_datatuple
                                  :nrep_loc sloc
                                  :ndata_name sname
                                  :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple")
                                  :ntup_comp formbodtup))
           )
      (add_nctx_data ncx nbodtupdata)
      (multiple_put_nth slotup (get_int citer_body_formals) nbodtupdata)
      )
;;; fill the citer_expbefore of insdata
    (fill_normal_expansion citexpbef expbeftup ncx sloc)
    (let ( (nbeftupdata  (instance class_nrep_datatuple
                                   :nrep_loc sloc
                                   :ndata_name sname
                                   :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple")
                                   :ntup_comp expbeftup))
           )
      (add_nctx_data ncx nbeftupdata)
      (multiple_put_nth slotup (get_int citer_expbefore) nbeftupdata)
      )
;;; fill the citer_expafter of insdata
    (fill_normal_expansion citexpaft expafttup ncx sloc)
    (let ( (nafttupdata  (instance class_nrep_datatuple
                                   :nrep_loc sloc
                                   :ndata_name sname
                                   :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple")
                                   :ntup_comp expafttup))
           )
      (add_nctx_data ncx nafttupdata)
      (multiple_put_nth slotup (get_int citer_expafter) nafttupdata)
      )
    (assert_msg "check citbind" (is_a citbind class_citerator_binding) citbind)
    (put_fields citbind :fixbind_data insdata)
;;;;;;;
    ;; return the data
    (debug "normexp_defciterator return insdata" insdata)
    (return insdata ())
    ))
(install_method class_source_defciterator normal_exp normexp_defciterator)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a citeration
(defun normexp_citeration (recv env ncx psloc)
  (debug "normexp_citeration recv" recv)
  (assert_msg "check citeration recv" (is_a recv class_source_citeration) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (unsafe_get_field :loca_location recv))
         (soper (unsafe_get_field :sciter_oper recv))
         (sargs (unsafe_get_field :sargop_args recv))
         (svbind (unsafe_get_field :sciter_varbind recv))
         (sbody (unsafe_get_field :sciter_body recv))
         (nbndtup (make_multiple discr_multiple (multiple_length svbind)))
         (bodyenv (fresh_env env))
         ;; we need to remove or add stuff from the symbol cache map, as normexp_let does
         (sycmap (unsafe_get_field :nctx_symbcachemap ncx))
         ;; the list of symbol to remove at end from the above map
         (uncachelist (make_list discr_list))
         )
    (assert_msg "check soper" (is_a soper class_citerator) soper)
    ;; normalize the iterator input arguments
    (multicall
     (nargs nbindings)
     (normalize_tuple sargs env ncx sloc)
     (if (null nbindings) (setq nbindings (make_list discr_list)))
     (debug "normexp_citeration nargs=" nargs " nbindings=" nbindings)
     (let ( (starformals (unsafe_get_field :citer_start_formals soper)) )
       (debug "normexp_citeration starformals" starformals)
       (let ( (:long nbformals (multiple_length starformals))
              (:long nbargs (multiple_length nargs))
              )
       (when (!=i nbformals nbargs)
             (error_at sloc "start formals $1 and actuals $2 lengths mismatch in citerator $3" nbformals nbargs (unsafe_get_field :named_name soper))
             (return)))
       (multiple_every_both 
        nargs starformals
        (lambda (curnarg curforb :long ix)
          (debug "normexp_citeration curnarg=" curnarg " curforb=" curforb " ix=" ix)
          (assert_msg "check curforb" (is_a curforb class_formal_binding) curforb)
          (let ( (curctyp (get_ctype curnarg env)) 
                 (formctyp (unsafe_get_field :fbind_type curforb))
                 (formarg (unsafe_get_field :binder curforb))
                 )
            (if (== curctyp formctyp)
                (let ( (nlbind (instance class_normal_let_binding
                                         :letbind_loc sloc
                                         :binder formarg
                                         :letbind_type curctyp
                                         :letbind_expr curnarg
                                         )) )
                  (multiple_put_nth nbndtup ix nlbind)
                  )
              (progn
                (error_at sloc "start formal $1 and actual arg #$2 type mismatch, got $3 expecting $4, in citerator $5"_ 
                          (get_field :named_name formarg)
                          ix
                          (get_field :named_name curctyp)
                          (get_field :named_name formctyp)
                          (unsafe_get_field :named_name soper))
                ))
            ))
        )
       (debug "normexp_citeration nbndtup" nbndtup)
       ;; bind the local vars
       (debug "normexp_citeration svbind" svbind)
       (let ( (citbform (unsafe_get_field :citer_body_formals soper))
              (:long nbcitbform (multiple_length citbform))
              (nlocbindtup (make_multiple discr_multiple nbcitbform))
              (nsymocctup (make_multiple discr_multiple nbcitbform))
              )
         (debug "normexp_citeration citbform" citbform)
         (let ( (:long nbsvbind (multiple_length svbind))
                )
           (when (!=i nbcitbform nbsvbind)
               (error_at sloc 
                         "body formals #$1 and actuals #$2 length mismatch in citerator $3"_ 
                         nbcitbform nbsvbind (unsafe_get_field :named_name soper))
               (return)))
         (multiple_every_both 
          svbind citbform
          (lambda (curvbind curbform :long ix)
            (debug "normexp_citeration curvbind=" curvbind 
                   " curbform=" curbform " ix=" ix)
            (assert_msg "check curvbind" (is_a curvbind class_formal_binding) curvbind)
            (assert_msg "check curbform" (is_a curbform class_formal_binding) curbform)
            (let ( (curvsym (unsafe_get_field :binder curvbind))
                   (curctyp (unsafe_get_field :fbind_type curvbind))
                   (curvfor (unsafe_get_field :binder curbform))
                   (forctyp (unsafe_get_field :fbind_type curbform))
                   )
              (if (== curctyp forctyp)
                  (let ( (nlvbind (instance class_normal_let_binding
                                            :letbind_loc sloc
                                            :binder curvsym
                                            :letbind_type curctyp
                                            :letbind_expr ()
                                            ))
                         (clocc (instance class_nrep_locsymocc
                                          :nrep_loc sloc
                                          :nocc_ctyp curctyp
                                          :nocc_symb curvsym
                                          :nocc_bind nlvbind))
                         )
                    (multiple_put_nth nlocbindtup ix nlvbind)
                    (multiple_put_nth nsymocctup ix clocc)
                    (debug "normexp_citeration nlvbind" nlvbind)
                    ;;(put_env bodyenv nlvbind)
                    ;; update the curvsym in the symbol cache map to
                    ;; ensure that it will be normalized as the same
                    ;; local symbol occurence
                    (mapobject_put sycmap curvsym clocc)
                    (debug "normexp_citeration updated sycmap=" sycmap " clocc=" clocc)
                    (list_append uncachelist curvsym)
                    )
                (progn
                  (error_at sloc "local formal type $1 and actual type $2 for formal $3 #$4 mismatch in citerator $5"_ 
                            (get_field :named_name forctyp)
                            (get_field :named_name curctyp)
                            (get_field :named_name curvsym)
                            ix (unsafe_get_field :named_name soper))
                  ))
              )
            (put_env bodyenv curvbind)
            ))
         (debug "normexp_citeration nlocbindtup=" nlocbindtup
                " nsymocctup=" nsymocctup)
         (multicall
          (nbody nbodbindings)
          (normalize_tuple sbody bodyenv ncx sloc)
          (debug "normexp_citeration nbody=" nbody " nbodbindings=" nbodbindings)
          (let ( (citstate (unsafe_get_field :citer_state soper))
                 (citstsym (clone_symbol citstate))
                 (nchint (instance class_nrep_checksignal
                                   :nrep_loc sloc))
                 (citstbind (instance class_normal_let_binding
                                      :letbind_loc sloc
                                      :binder citstsym
                                      :letbind_type ctype_void
                                      :letbind_expr nchint))
                 (citstocc (instance class_nrep_locsymocc
                                     :nrep_loc sloc
                                     :nocc_ctyp ctype_void
                                     :nocc_symb citstsym
                                     :nocc_bind citstbind))
                 (citexpbefore (unsafe_get_field :citer_expbefore soper))
                 (citexpafter (unsafe_get_field :citer_expafter soper))
                 (citlocmap (make_mapobject discr_map_objects (+i 10 nbcitbform)))
                 (citexpander 
                  (lambda (xtup)
                    (debug "normexp_citeration expanding xtup=" xtup)
                    (multiple_map 
                     xtup 
                     (lambda (curelem :long ix)
                       (if (is_a curelem class_symbol)
                           (let ( (exelem (mapobject_get citlocmap curelem)) )
                             (if (null exelem)
                                 (debug "normexp_citeration bad curelem" curelem))
                             (assert_msg "check exelem in citeration" exelem)
                             exelem)
                         curelem)
                       ))
                    ))
                 )
            (mapobject_put citlocmap citstate citstocc)
            (debug "normexp_citeration  again starformals=" starformals
                   " nsymocctup=" nsymocctup)
            (multiple_every_both 
             starformals nargs
             (lambda (curvloc curnarg :long ix)
               (debug "normexp_citeration curvloc=" curvloc " curnarg=" curnarg)
               (mapobject_put citlocmap (unsafe_get_field :binder curvloc) curnarg)
               ))
            (debug "normexp_citeration  middle citlocmap=" citlocmap
                   " citbform=" citbform)
            (multiple_every
             citbform
             (lambda (curformb :long ix)
               (assert_msg "check curform" (is_a curformb class_formal_binding) curformb)
               (mapobject_put citlocmap
                              (unsafe_get_field :binder curformb)
                              (multiple_nth  nsymocctup ix))
               
               ))
            (debug "normexp_citeration citlocmap done" citlocmap)
            (let ( (chkbefore (citexpander citexpbefore))
                   (chkafter (citexpander citexpafter))
                   )
              (debug "normexp_citeration chkbefore=" chkbefore
                     " chkafter=" chkafter)
              (let ( (nciter
                      (instance  class_nrep_citeration
                                 :nrep_loc sloc
                                 :nciter_citerator soper
                                 :nciter_locbindings nlocbindtup
                                 :nciter_chunkbefore chkbefore
                                 :nciter_body nbody
                                 :nciter_statocc citstocc
                                 :nciter_bodbindings nbodbindings
                                 :nciter_chunkafter chkafter
                                 ))
                     (csym (clone_symbol (unsafe_get_field :named_name soper)))
                     (cbind (instance class_normal_let_binding
                                      :letbind_loc sloc
                                      :binder csym
                                      :letbind_type ctype_void
                                      :letbind_expr nciter))
                     (clocc (instance class_nrep_locsymocc
                                      :nrep_loc sloc
                                      :nocc_ctyp ctype_void
                                      :nocc_symb csym
                                      :nocc_bind cbind))
                     )
                (list_append nbindings cbind)
                ;; remove all required stuff from the symbol cache
                (list_every 
                 uncachelist
                 (lambda (csy) (mapobject_remove sycmap csy)))
                (debug "normexp_citeration nciter=" nciter
                       " result clocc=" clocc " nbindings=" nbindings)
                (return clocc nbindings)
                ))))))))
  )
(install_method class_source_citeration normal_exp normexp_citeration)







;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; normalize a DEFCMATCHER
(defun normexp_defcmatcher (recv env ncx psloc)
  (debug "normexp_defcmatcher recv=" recv "\n.. env=" debug_more env)
  (assert_msg "check defcmatcher recv" (is_a recv class_source_defcmatcher) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc   (unsafe_get_field :loca_location recv))
         (sname  (unsafe_get_field :sdef_name recv))
         (sformals (unsafe_get_field :sformal_args recv))
         (cmatcher (let ( (cm (unsafe_get_field :scmatdef_cmatcher recv)) )
                     (debug "normexp_defcmatcher cmatcher" cm)
                     (assert_msg "check cmatcher" (is_a cm class_cmatcher) cm)
                     cm))
         (cmbind (let ( (b (find_env env sname)) )
                   (debug "normexp_defcmatcher cmbind=" b "; sname=" sname)
                   (assert_msg "check cmbind" (is_a b class_cmatcher_binding) b)
                   b))
         (slotup (make_multiple discr_multiple (object_length cmatcher)))
         (inscma (unsafe_get_field :amatch_in cmatcher))
         (mbicma (unsafe_get_field :amatch_matchbind cmatcher))
         (outscma (unsafe_get_field :amatch_out cmatcher))
         (statcma (unsafe_get_field :cmatch_state cmatcher))
         (testcma (unsafe_get_field :cmatch_exptest cmatcher))
         (fillcma (unsafe_get_field :cmatch_expfill cmatcher))
         (opercma (unsafe_get_field :cmatch_expoper cmatcher))
         (instup (make_multiple discr_multiple (multiple_length inscma)))
         (outstup (make_multiple discr_multiple (multiple_length outscma)))
         (testtup (if testcma (make_multiple discr_multiple (multiple_length testcma))))
         (filltup (if fillcma (make_multiple discr_multiple (multiple_length fillcma))))
         (opertup (if opercma (make_multiple discr_multiple (multiple_length opercma))))
         ;; map of formal symbol -> data of formal_binding
         (formsymbmap (make_mapobject discr_map_objects
                                      (+i 5 (*i (+i (multiple_length inscma) (multiple_length outscma)) 2))))
         (namstrdata (instance class_nrep_datastring
                               :nrep_loc sloc
                               :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
                               :nstr_string (unsafe_get_field :named_name sname)))
         (insdata (instance class_nrep_datainstance
                            :nrep_loc sloc
                            :ndata_name sname
                            :ndata_discrx (normal_predef class_cmatcher ncx sloc "class_cmatcher") 
                            :ninst_hash (make_integerbox discr_integer (obj_hash cmatcher))
                            :ninst_slots slotup
                            )) 
         )
    (add_nctx_data ncx insdata)
    (add_nctx_data ncx namstrdata)
;;; fill the named_name of insdata
    (multiple_put_nth slotup (get_int named_name) namstrdata)
;;; fill the amatch_in of insdata
    (fill_normal_formals inscma instup formsymbmap env ncx sloc)
    (let ( (instupdata (instance class_nrep_datatuple
                                 :nrep_loc sloc
                                 :ndata_name sname
                                 :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple")
                                 :ntup_comp instup))
           )
      (add_nctx_data ncx instupdata)
      (multiple_put_nth slotup (get_int amatch_in) 
                        instupdata)
      )
;;; fill the amatch_matchbind of insdata
    (let ( (mbdata (fill_normal_formalbind mbicma formsymbmap env ncx sloc)) )
      (multiple_put_nth slotup (get_int amatch_matchbind)
                        mbdata)
      )
;;; fill the amatch_out of insdata
    (fill_normal_formals outscma outstup formsymbmap env ncx sloc)
    (let ( (outstupdata (instance class_nrep_datatuple
                                  :nrep_loc sloc
                                  :ndata_name sname
                                  :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple")
                                  :ntup_comp outstup))
           )
      (add_nctx_data ncx outstupdata)
      (multiple_put_nth slotup (get_int amatch_out) 
                        outstupdata)
      )
;;; fill the cmatch_state of insdata
    (assert_msg "check statcma" (is_a statcma class_symbol) statcma)
    (let ( (nstatcmadata (normal_symbol_data statcma ncx sloc)) )
      (multiple_put_nth slotup (get_int cmatch_state) 
                        nstatcmadata)
      )
;;; fill the cmatch_exptest of insdata
    (when (is_multiple testcma)
      (fill_normal_expansion testcma testtup ncx sloc)
      (let ( (ntesttupdata  (instance class_nrep_datatuple
                                      :nrep_loc sloc
                                      :ndata_name sname
                                      :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple")
                                      :ntup_comp testtup))
             )
        (add_nctx_data ncx ntesttupdata)
        (multiple_put_nth slotup (get_int cmatch_exptest) ntesttupdata)
        )
      )
;;; fill the cmatch_expfill of insdata
    (when (is_multiple fillcma)
      (fill_normal_expansion fillcma filltup ncx sloc)
      (let ( (nfilltupdata  (instance class_nrep_datatuple
                                      :nrep_loc sloc
                                      :ndata_name sname
                                      :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple")
                                      :ntup_comp filltup))
             )
        (add_nctx_data ncx nfilltupdata)
        (multiple_put_nth slotup (get_int cmatch_expfill) nfilltupdata)
        )
      )
;;; fill the cmatch_expoper of insdata
    (when (is_multiple opercma)
      (fill_normal_expansion opercma opertup ncx sloc)
      (let ( (nopertupdata  (instance class_nrep_datatuple
                                      :nrep_loc sloc
                                      :ndata_name sname
                                      :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple")
                                      :ntup_comp opertup))
             )
        (add_nctx_data ncx nopertupdata)
        (multiple_put_nth slotup (get_int cmatch_expoper) nopertupdata)
        )
      )
;;; put the data in the binding
    (put_fields cmbind :fixbind_data insdata)
    ;; return the data
    (debug "normexp_defcmatcher return insdata=" insdata)
    (return insdata ())
    )
  )
(install_method class_source_defcmatcher normal_exp normexp_defcmatcher)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a DEFUNMATCHER
(defun normexp_defunmatcher (recv env ncx psloc)
  (debug "normexp_defunmatcher start recv=" recv)
  (assert_msg "normexp_defunmatcher check recv" (is_a recv class_source_defunmatcher) recv)
  (assert_msg "normexp_defunmatcher check env" (is_a env class_environment))
  (assert_msg "normexp_defunmatcher check ncx" (is_a ncx class_normalization_context))
  (let ( (sloc (unsafe_get_field :loca_location recv))
         (sname (unsafe_get_field :sdef_name recv))
         (smatched (multiple_nth (get_field :sformal_args recv) 0))
         (sins (unsafe_get_field :sfumatdef_ins recv))
         (souts (unsafe_get_field :sfumatdef_outs recv))
         (smatchf (unsafe_get_field :sfumatdef_matchf recv))
         (sapplyf (unsafe_get_field :sfumatdef_applyf recv))
         (sdata (unsafe_get_field :sfumatdef_data recv))
         (resbinds (make_list discr_list))
         (insfma (subseq_multiple sins 1 -1))
         (mbifma (multiple_nth sins 0))
         (fmbind (let ( (b (find_env env sname)) )
                   (debug "normexp_defunmatcher fmbind" b)
                   (assert_msg "check fmbind" (is_a b class_funmatcher_binding) b)
                   b))
         (funmatcher (get_field :fmbind_funmatcher fmbind))
         )
    (debug "normexp_defunmatcher made funmatcher" funmatcher)
    (assert_msg "check smatched" (is_a smatched class_formal_binding) smatched)
    (assert_msg "check sins" (is_multiple sins) sins)
    (assert_msg "check souts" (is_multiple souts) souts)
    (assert_msg "check mbifma" (is_a mbifma class_formal_binding) mbifma)
    (multicall
     (nmatchf nmabinds)
     (normal_exp smatchf env ncx sloc)
     (debug "normexp_defunmatcher nmatchf" nmatchf)
     (list_append2list resbinds nmabinds)
     (multicall
      (napplf napbinds)
      (normal_exp sapplyf env ncx sloc)
      (debug "normexp_defunmatcher napplf" napplf)
      (list_append2list resbinds napbinds)
      (multicall
       (ndata ndabinds)
       (normal_exp sdata env ncx sloc)
       (debug "normexp_defunmatcher ndata=" ndata " resbinds=" resbinds)
       (let (
             (namstrdata (instance class_nrep_datastring
                                   :nrep_loc sloc
                                   :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
                                   :nstr_string (unsafe_get_field :named_name sname)))
             (slotup (make_multiple discr_multiple (object_length funmatcher)))
             (insdata (instance class_nrep_datainstance
                                :nrep_loc sloc
                                :ndata_name sname
                                :ndata_discrx (normal_predef class_cmatcher ncx sloc "class_funmatcher") 
                                :ninst_hash (make_integerbox discr_integer (nonzero_hash))
                                :ninst_slots slotup
                                )) 
             (instup (make_multiple discr_multiple (multiple_length insfma)))
             (outstup (make_multiple discr_multiple (multiple_length souts)))
             ;; map of formal symbol -> data of formal_binding
             (formsymbmap (make_mapobject discr_map_objects
                                          (+i 5 (*i (+i (multiple_length insfma) 
                                                        (multiple_length souts)) 2))))
             )
         (add_nctx_data ncx namstrdata)
         (add_nctx_data ncx insdata)
;;; fill the named_name of insdata
         (multiple_put_nth slotup (get_int named_name) namstrdata)
;;; fill the amatch_in of insdata
         (fill_normal_formals insfma instup formsymbmap env ncx sloc)
         (let ( (instupdata (instance class_nrep_datatuple
                                      :nrep_loc sloc
                                      :ndata_name sname
                                      :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple")
                                      :ntup_comp instup))
                )
           (add_nctx_data ncx instupdata)
           (multiple_put_nth slotup (get_int amatch_in) 
                             instupdata)
           )
;;; fill the amatch_matchbind of insdata
         (let ( (mbdata (fill_normal_formalbind mbifma formsymbmap env ncx sloc)) )
           (multiple_put_nth slotup (get_int amatch_matchbind)
                             mbdata)
           )
;;; fill the amatch_out of insdata
         (fill_normal_formals souts outstup formsymbmap env ncx sloc)
         (let ( (outstupdata (instance class_nrep_datatuple
                                       :nrep_loc sloc
                                       :ndata_name sname
                                       :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple")
                                       :ntup_comp outstup))
                )
           (add_nctx_data ncx outstupdata)
           (multiple_put_nth slotup (get_int amatch_out) 
                             outstupdata)
           )
;;; fill the fmatch_matchf of insdata
         (multiple_put_nth slotup (get_int fmatch_matchf)
                           nmatchf)
;;; fill the fmatch_applyf of insdata
         (multiple_put_nth slotup (get_int fmatch_applyf)
                           napplf)
;;; fill the fmatch_data of insdata
         (multiple_put_nth slotup (get_int fmatch_data)
                           ndata)
;;; put the data in the binding
         (put_fields fmbind :fixbind_data insdata)
;;; make a funmatcher binding
         (debug "normexp_defunmatcher final fmbind" fmbind)
         (compile_warning "$@$incomplete normexp_defunmatcher" ())
;;; return insdata and resbinds
         (debug "normexp_defunmatcher return insdata=" insdata
                " resbinds=" resbinds)
         (return insdata resbinds)
         )
       )))
    ))
(install_method class_source_defunmatcher normal_exp normexp_defunmatcher)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a DEFCLASS
(defun normexp_defclass (recv env ncx psloc)
  (debug "normexp_defclass recv=" recv)
  (assert_msg "check defclass recv" (is_a recv class_source_defclass) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc   (unsafe_get_field :loca_location 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) sclabind)
    (let ( (claobj (unsafe_get_field :cbind_class sclabind)) 
           (namsymdata (normal_symbol_data sname ncx sloc))
           (namstr (unsafe_get_field :named_name sname))
           (namstrdata
            (instance class_nrep_datastring
                      :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
                      :nstr_string namstr
                      ))
           (claslots (make_multiple discr_multiple (obj_len claobj)))
           (cladata 
            (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 'MELTOBMAG_OBJECT
                      )) 
           (ancseq (unsafe_get_field :class_ancestors claobj))
           (:long nbanc (multiple_length ancseq))
           (anctup (make_multiple discr_multiple nbanc))
           (ancdata (instance 
                     class_nrep_datatuple
                     :nrep_loc sloc
                     :ndata_name sname
                     :ndata_discrx (normal_predef discr_class_sequence ncx sloc "discr_class_sequence")
                     :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 (instance 
                     class_nrep_datatuple
                     :nrep_loc sloc
                     :ndata_name sname
                     :ndata_discrx (normal_predef discr_field_sequence ncx sloc "discr_field_sequence")
                     :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 "chechk namstr" (is_string namstr) namstr)
      ;; Issue a warning if we have no super class and if the class is
      ;; not predefined.
      (if (and (null superbind)
               (null spredef))
          (warning_strv sloc "DEFCLASS of class without :SUPER -class" 
                        namstr))
      ;; Issue a warning if namstr does not start with "CLASS_" to
      ;; enforce a coding convention.
      (let ( (:long dontstartwith_class 0)
             )
        (code_chunk 
         startwithclass
         #{ $DONTSTARTWITH_CLASS 
              = strncmp (melt_string_str ((melt_ptr_t) $NAMSTR), 
                         "CLASS_", strlen("CLASS_"));
         }#)
        (if dontstartwith_class
            (warning_strv sloc "DEFCLASS-ed name should start with CLASS_ !" 
                          namstr)))
      ;;
      (assert_msg "check claobj" (is_a claobj class_class) claobj)
      (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) sclabind)
      (put_fields sclabind :fixbind_data 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 
                       (instance class_nrep_multacc
                                 :nrep_loc sloc
                                 :naccm_mul
                                 (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) ownfldbind)
                 (let ( (ownfldsym (unsafe_get_field :binder ownfldbind))
                        (ownfld (unsafe_get_field :flbind_field ownfldbind))
                        )
                   (assert_msg "check ownfldsym" (is_a ownfldsym class_symbol) ownfldsym)
                   (assert_msg "check ownfld" (is_a ownfld class_field) ownfld)
                   (let ( (ownfldsymdata (normal_symbol_data ownfldsym ncx sloc)) 
                          (ownfldslots (make_multiple discr_multiple (obj_len ownfld)))
                          (ownflstrdata 
                           (instance class_nrep_datastring
                                     :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
                                     :nstr_string  (unsafe_get_field :named_name ownfld)
                                     ))
                          (ownfldata (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
                     (put_fields ownfldbind :fixbind_data 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
                       (instance class_nrep_multacc
                                 :nrep_loc sloc
                                 :naccm_mul
                                 (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
      (return cladata ())
      )))
(install_method class_source_defclass normal_exp normexp_defclass)




;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a DEFINSTANCE
(defun normexp_definstance (recv env ncx psloc)
  (debug "normexp_definstance recv=" recv)
  (assert_msg "check definstance recv" (is_a recv class_source_definstance) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc   (unsafe_get_field :loca_location recv))
         (sname  (unsafe_get_field :sdef_name recv))
         (spredef (unsafe_get_field :sobj_predef recv))
         (sdocstr (unsafe_get_field :sdef_doc 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))
         (nbindcont (reference nbindlist))
         (bindins (find_env env sname))
         (namdata (normal_symbol_data sname ncx sloc))
         ;; data representing the class
         (icladata (if (is_a sinstclasym class_symbol) 
                       (normal_exp sinstclasym env ncx sloc)))
         )
    (debug "normexp_definstance bindins" bindins)
    (assert_msg "check bindins" (is_a  bindins class_instance_binding) bindins)
    (when (is_not_a icladata class_nrep)
      (error_at sloc "invalid class $1 in definstance" (unsafe_get_field :named_name sname))
      (return ()))
    (cond
     ( (null spredef) () )
     ( (is_integerbox spredef) () )
     ( (is_a spredef class_symbol) () )
     (:else
      (error_at sloc "bad predef $1 in DEFINSTANCE"  (unsafe_get_field :named_name sname))
      (return ())))
    (assert_msg "check sinstclass" (is_a sinstclass class_class) sinstclass)
    (assert_msg "check sinstclasym" (is_a sinstclasym class_symbol) sinstclasym)
    (let (
          (slotup (make_multiple discr_multiple
                                 (multiple_length (unsafe_get_field :class_fields sinstclass))))
          (insdata (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
                             :ninst_objnum sinstobjnum
                             )) 
          )
      (add_nctx_data ncx insdata)
      (put_env env bindins)
      (put_fields bindins :fixbind_data insdata)
      ;; scan the fields initialization
      (foreach_in_multiple
       (sinstfields)
       (flda :long ix)
       (debug "normexp_definstance flda" flda)
       (assert_msg "check flda" (is_a flda class_source_fieldassign) flda)
       (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) curfld)
         (when (!= (multiple_nth (unsafe_get_field :class_fields sinstclass) curoff) 
                   curfld)
           (error_at sloc
                     "inappropriate field $1 in DEFINSTANCE"
                     (get_field :named_name curfld)
                     )
           (return))
         (debug "normexp_definstance field curexp" curexp)
         (multicall
          (ncur nbindcur)
          (normal_exp curexp env ncx sloc)
          (debug "normexp_definstance field ncur=" ncur " nbindcur=" nbindcur)
          (let ( (curctype (get_ctype ncur env))
                 )
            (if (!= curctype ctype_value)
                (error_at sloc
                          "field $1 in DEFINSTANCE don't get a value but a $2"
                          (get_field :named_name curfld) (get_field :named_name curctype)))
            )
          (multiple_put_nth slotup curoff ncur)
          (if (is_list nbindcur)
              (let ( (thebindlist (deref nbindcont)))
                (setq thebindlist (list_append2list thebindlist nbindcur))
                (set_ref nbindcont thebindlist))))))
;;; put the binding into the data
      (let ( (thebindlist (deref nbindcont)) 
             (nbindtup (list_to_multiple thebindlist discr_multiple))
             )
        (if (>i (multiple_length nbindtup) 0) 
            (unsafe_put_fields insdata :ndata_locbind nbindtup))
        ;; return the data
        (debug "normexp_definstance return insdata" insdata)
        (return insdata ())
        ))))
(install_method class_source_definstance normal_exp normexp_definstance)


;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a DEFVAR for a static variable
(defun normexp_defvar (recv env ncx psloc)
  (debug "normexp_defvar recv=" recv)
  (assert_msg "check defvar recv" (is_a recv class_source_defvar) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( (sloc (unsafe_get_field :loca_location recv))
         (sname (unsafe_get_field :sdef_name recv))
         (modctx (unsafe_get_field :nctx_modulcontext ncx))
         (curproc (unsafe_get_field :nctx_curproc ncx)) 
         (bnbvar (unsafe_get_field :mocx_varcount modctx))
         (varlist (unsafe_get_field :mocx_varlist modctx))
         (:long numvar (+i (get_int bnbvar) 1))
         )
    (debug "normexp_defvar modctx=" modctx)
    (when (is_not_a curproc class_nrep_initproc)
      (error_at sloc "(DEFVAR $1) can appear only at top-level"_ sname)
      (return))
    (multicall
     (vbind procs gotenv)
     (find_enclosing_env env sname)
     (debug "normexp_defvar vbind=" vbind "\n procs=" procs "\n gotenv=" gotenv)
     (when 
         (or (!= gotenv env) 
             (is_not_a vbind class_variable_binding))
       (error_at sloc "cannot redefine variable $1 with DEFVAR"_ 
                 (get_field :named_name sname))
       (return))
     (debug "normexp_defvar class_normal_module_variable_binding=" class_normal_module_variable_binding)
     (let (
           (bnumvar (constant_box numvar))
           (varbnd (instance class_normal_module_variable_binding
                             :binder sname
                             :nvarb_num bnumvar))
           )
       (debug "normexp_defvar varbnd=" varbnd)
       (put_int bnbvar numvar)
       (put_env env varbnd)
       (list_append varlist varbnd)
       (debug "normexp_defvar updated varlist=" varlist)
       (return)
       ))))
(install_method class_source_defvar normal_exp normexp_defvar)
    
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a DEFINE for a constant
(defun normexp_define (recv env ncx psloc)
  (assert_msg "check define recv" (is_a recv class_source_define) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (debug "normexp define recv" recv)
  (shortbacktrace_dbg "normexp_define" 7)
  (let ( 
        (sloc (unsafe_get_field :loca_location recv))
        (sname (unsafe_get_field :sdef_name recv))
        (sbody (unsafe_get_field :sdefine_body recv))
        (binddef (let ( (bdf (find_env env sname))
                        ) 
                   (debug "normexp_define binddef bdf=" bdf)
                   bdf
                   ))
        (namdata (normal_symbol_data sname ncx sloc))
        (curproc (unsafe_get_field :nctx_curproc ncx)) 
        (newenv (fresh_env env))
        (locbind (instance class_normal_let_binding
                           :letbind_loc sloc
                           :binder sname
                           :letbind_type ctype_value
                           :letbind_expr ()
                           ))
        (sycmap (unsafe_get_field :nctx_symbcachemap ncx))
        )
    (debug "normexp_define namdata=" namdata " binddef=" binddef " sycmap=" sycmap)
    (assert_msg "check body tuple" (is_multiple sbody) sbody)
    (assert_msg "check binddef" (is_a binddef class_defined_value_binding) binddef)
    (debug "normexp_define curproc=" curproc " newenv=" newenv)
    ;; TODO:: maybe we could have internal defines for constants...
    (when (is_not_a curproc class_nrep_initproc)
      (error_at sloc "(DEFINE $1 ...) can appear only at top-level"_ sname)
      (return))
    (put_env newenv locbind)
    (debug "normexp_define sbody=" sbody "\n newenv=" newenv)
    (multicall
     (nbody nbindings)
     (normalize_tuple sbody newenv ncx sloc)
     (debug "normexp_define nbody=" nbody " nbindings=" nbindings
            " sname=" sname)
     (if (null nbindings)
         (setq nbindings (make_list discr_list)))
     (let (
           (procdefbinds (get_field :ninit_defbinds curproc))
           (ndefname (normexp_symbol sname env ncx sloc))
           (:long nbodylen (multiple_length nbody))
           (nlastbody (multiple_nth nbody -1))
           (newbody (make_multiple discr_multiple (+i nbodylen 2)))
           (snamestr (get_field :named_name sname))
           (nlastassign (instance class_nrep_setq
                                  :nrep_loc sloc
                                  :nstq_var ndefname
                                  :nstq_exp nlastbody))
           )
       (debug "normexp_define nlastassign=" nlastassign " ndefname=" ndefname)
       (list_every nbindings (lambda (nb) (put_env newenv nb)))
       (foreach_in_multiple
        (nbody)
        (curnbody :long bodix)
        (multiple_put_nth newbody bodix curnbody))
       (multiple_put_nth newbody nbodylen nlastassign)
       (multiple_put_nth newbody (+i nbodylen 1) ndefname)
       (list_append procdefbinds binddef)
       (debug "normexp_define updated procdefbinds=" procdefbinds
              " ndefname=" ndefname " newbody=" newbody)
       (let ( (curctype (get_ctype ndefname env))
              (lastctype (get_ctype nlastbody newenv))
              )
         (if (!= curctype ctype_value)
             (error_at sloc "DEFINE-d name $1 is not a value but a $2"_ 
                       snamestr (get_field :named_name curctype)))
         (if (!= lastctype ctype_value)
             (error_at sloc "(DEFINE $1 ...) body don't end with a value but with a $2"_ snamestr
                       (get_field :named_name lastctype)))
         )
       (debug "normexp_define newbody=" newbody " sname=" sname " sycmap=" sycmap)
       (let ( (nwrlet (wrap_normal_letseq newbody nbindings sloc))
              (nlocbindings (list locbind))
              (syca (mapobject_get sycmap sname))
              )
         (debug "normexp_define nwrlet=" nwrlet)
         (debug "normexp_define syca=" syca " locbind=" locbind)
         (assert_msg "check syca" (is_a syca class_nrep_defined_constant) syca)
         (mapobject_remove sycmap sname)
         (debug "normexp_define shrinked updated sycmap=" sycmap)
         (debug "normexp_define return nwrlet=" nwrlet  " nlocbindings=" nlocbindings)
         (return nwrlet nlocbindings)
         )))))
(install_method class_source_define normal_exp normexp_define)



;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a DEFSELECTOR
(defun normexp_defselector (recv env ncx psloc)
  (debug "normexp defselector recv=" recv)
  (assert_msg "check defselector recv" (is_a recv class_source_defselector) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( 
        (sloc (unsafe_get_field :loca_location recv))
        (sname (unsafe_get_field :sdef_name recv))
        (spredef (unsafe_get_field :sobj_predef recv))
        (sdocstr (unsafe_get_field :sdef_doc 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))
        (sformals (unsafe_get_field :sdefsel_formals recv))
        (nbindlist (make_list discr_list))
        (nbindcont (reference nbindlist))
        (bindsel (find_env env sname))
        (namdata (normal_symbol_data sname ncx sloc))
        ;; data representing the class
        (icladata (if (is_a sinstclasym class_symbol) 
                      (normal_exp sinstclasym env ncx sloc)))
        )
    (assert_msg "check bindsel" (is_a bindsel class_selector_binding) bindsel)
    (when  (is_not_a icladata class_nrep)
          (error_at sloc "invalid class in DEFSELECTOR $1"_ (unsafe_get_field :named_name sname))
          (return ()))
    (if spredef
        (when (not (or (is_integerbox spredef) (is_a spredef class_symbol)))
          (error_at sloc "bad predef in DEFSELECTOR $1"  (unsafe_get_field :named_name sname))
          (return ())))
    (assert_msg "check sinstclass" (is_a sinstclass class_class) sinstclass)
    (assert_msg "check sinstclasym" (is_a sinstclasym class_symbol) sinstclasym)
    (assert_msg "check sname" (is_a sname class_symbol) sname)
    (let (
          (slotup (make_multiple discr_multiple
                                 (multiple_length (unsafe_get_field :class_fields sinstclass))))
          (namstrdata (instance class_nrep_datastring
                                :nrep_loc sloc
                                :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
                                :nstr_string (unsafe_get_field :named_name sname)))
          (insdata (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
                             :ninst_objnum sinstobjnum
                             )) 
          (formsymbmap (make_mapobject discr_map_objects (+i 3 (*i (multiple_length sformals) 2))))
          (nformtup (if sformals
                        (let ( (:long nbformals (multiple_length sformals))
                               (nformaltuple (make_multiple discr_multiple nbformals))
                               (nformdata (instance 
                                           class_nrep_datatuple
                                           :nrep_loc sloc
                                           :ndata_name sname
                                           :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple")
                                           :ntup_comp nformaltuple))
                               )
                          (fill_normal_formals sformals nformaltuple formsymbmap env ncx sloc)
                          (add_nctx_data ncx nformdata)   
                          (fill_data_slot insdata  sdefsel_formals nformdata)
                          nformaltuple
                          )))
          )
      (add_nctx_data ncx insdata)
      (add_nctx_data ncx namstrdata)
      (put_fields bindsel :fixbind_data insdata)
      ;; scan the fields initialization
      (foreach_in_multiple
       (sinstfields)
       (flda :long ix)
       (assert_msg "check flda" (is_a flda class_source_fieldassign) flda)
       (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) curfld)
         (assert_msg "good curfld"
                     (== (multiple_nth (unsafe_get_field :class_fields sinstclass) curoff) 
                         curfld) curoff curfld)  
         (multicall
          (ncur nbindcur)
          (normal_exp curexp env ncx sloc)
          (multiple_put_nth slotup curoff ncur)
          (if (is_list nbindcur)
              (let ( (thebindlist (deref nbindcont)))
                (setq thebindlist (list_append2list thebindlist nbindcur))
                (set_ref nbindcont thebindlist))))))
;;; put the binding into the data
      (let ( (thebindlist (deref nbindcont)) 
             (nbindtup (list_to_multiple thebindlist discr_multiple))
             )
        (if (>i (multiple_length nbindtup) 0) 
            (unsafe_put_fields insdata :ndata_locbind nbindtup))
        ;; force the name of the selectordata
        (multiple_put_nth slotup (get_int named_name) namstrdata)
        (if (is_a bindsel class_selector_binding)
            (put_fields bindsel :fixbind_data insdata))
        ;; return the data
        (debug "normexp_defselector return insdata" insdata)
        (return insdata ())
        ))))
(install_method class_source_defselector normal_exp normexp_defselector)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; internal function for value export
;;
;;; sym is the exported symbol
;;
;;; nexp is the normalized expression of its value
;;
(defun normal_exported_value (sym nexp env ncx psloc bindslist)
  (debug "normal_exported_value start sym=" sym " nexp=" nexp)
  (assert_msg "check sym" (is_a sym class_symbol) sym)
  (assert_msg "check nexp" (is_a nexp class_nrep) nexp)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context))
  (assert_msg "check bindslist" (is_list bindslist) bindslist)
  (let ( (csymexpo (clone_symbol '_exported_))
         (symdata (normal_symbol_data sym ncx psloc))
         (iniproc (unsafe_get_field :nctx_initproc ncx))
         (curproc (unsafe_get_field :nctx_curproc ncx))
         (csbuf (let ( (sb (make_strbuf discr_strbuf)) )
                  (add2sbuf_strconst sb "norm.exp.val : ")
                  (add2sbuf_string sb (unsafe_get_field :named_name sym))
                  sb))
         (scurenvbox (instance class_source_current_module_environment_reference
                               :loca_location psloc
                               :cmec_comment (strbuf2string discr_string csbuf)))
         )
    (debug "normal_exported_value scurenvbox=" scurenvbox)
    (multicall 
     (ncurenvbox curenvbinds)
     (normal_exp scurenvbox env ncx psloc)
     (debug "normal_exported_value ncurenvbox=" ncurenvbox " curenvbinds=" curenvbinds)
     ;;; if we are not at toplevel it has no sense to call the cont_fresh_env!
     (list_append2list bindslist curenvbinds)
     (let (
           (argtup  (tuple symdata nexp ncurenvbox))
           (cbind (instance class_normal_let_binding
                            :letbind_loc psloc
                            :binder csymexpo
                            :letbind_type ctype_void
                            :letbind_expr 
                            (instance class_nrep_hook_call
                                      :nrep_loc psloc
                                      :nexpr_ctyp ctype_value
                                      :nhook_name '"HOOK_VALUE_EXPORTER"
                                      :nexpr_args argtup
                                      :nhook_called (normal_predef hook_value_exporter ncx
                                                                   psloc "hook_value_exporter")
                                      :nhook_outs (tuple)
                                      :nhook_descr (hook_data hook_value_exporter)
                                      )
                            ))
           (syocc (instance class_nrep_locsymocc
                            :nrep_loc psloc
                            :nocc_ctyp ctype_void 
                            :nocc_symb csymexpo
                            :nocc_bind cbind) )
           )
       (debug "normal_exported_value cbind=" cbind " syocc=" syocc)
       (list_append bindslist cbind)
       syocc
       ;;
       ))))


;;;; normalize an export_values
(defun normexp_export_values (recv env ncx psloc)
  ;; actually, export of values & classes could be simple.  the
  ;; export of a symbol should be expanded as the invocation of the
  ;; value exporter on the current module environment. we don't need
  ;; anything special in the initproc for the export.
;;;; this implies that a locally let-bound symbol could be passed to
;;;; export_values, some kind of strange practice.
  (debug "normexp_export_values recv=" recv)
  (assert_msg "check exportval recv" (is_a recv class_source_export_values) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( 
        (sloc (unsafe_get_field :loca_location recv))
        (sxnames (unsafe_get_field :sexport_names recv))
        (bindslist (make_list discr_list))
        (nilnrep (instance class_nrep_nil
                           :nrep_loc sloc))
        )
    (foreach_in_multiple
     (sxnames)
     (xnam :long ix)
       (assert_msg "check xnam" (is_a xnam class_symbol) xnam)
       (debug "normexp_export_values xnam" xnam)
       (multicall
        (nsym nsymbinds)
        (normal_exp xnam env ncx sloc)
        (debug "normexp_export_values nsym=" nsym " nsymbinds=" nsymbinds)
        (list_append2list bindslist nsymbinds)
        (debug "normexp_export_values again xnam=" xnam " bindslist=" bindslist)
        (let ( (nexpv (normal_exported_value xnam nsym env ncx sloc bindslist))
               )
          (debug "normexp_export_values normal_exported_value gave nexpv" nexpv)
          )))
    (debug "normexp_export_values final nilnrep=" nilnrep " bindslist=" bindslist)
    (return nilnrep bindslist)
    ))


(install_method class_source_export_values normal_exp normexp_export_values)

;;;; normalize an export_synonym
(defun normexp_export_synonym (recv env ncx psloc)
  ;; it should be a bit like export_values, since it create a value binding..
  (debug "normexp_export_synonym recv=" recv)
  (assert_msg "check exportsyn recv" (is_a recv class_source_export_synonym) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( 
        (sloc (unsafe_get_field :loca_location recv))
        (newname (unsafe_get_field :sexpsyn_newname recv))
        (oldname (unsafe_get_field :sexpsyn_oldname recv))
        (bindslist (make_list discr_list))
        (nilnrep (instance class_nrep_nil
                           :nrep_loc sloc))
        )
    (debug "normexp_export_synonym newname=" newname     " oldname=" oldname)
    (assert_msg "check newname" (is_a newname class_symbol) newname)
    (assert_msg "check oldname" (is_a oldname class_symbol) oldname)
    ;; when a class has a synonym, we should generate in the C code 
    ;;; const int meltclasslen__<SYNONYMNAME>
    ;; when a field has a synonym, we should generate in the C code
    ;;; const int meltfieldoff__<SYNONYMNAME> 
    (compile_warning "export_synonym should also generate a class length or field offset when needed")
    (multicall
     (noldsym noldsymbinds)
     (normal_exp oldname env ncx sloc)
     (debug "normexp_export_synonym noldsym=" noldsym " noldsymbinds=" noldsymbinds)
     (list_append2list bindslist noldsymbinds)
     (let ( (nexpv (normal_exported_value newname noldsym env ncx sloc bindslist))
            )
       (debug "normexp_export_synonym normal_exported_value gave nexpv=" nexpv
              " final nilnrep=" nilnrep
              " bindslist=" bindslist)
       (return nilnrep bindslist)
       ))))
      
(install_method class_source_export_synonym normal_exp normexp_export_synonym)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; normalize an export_class
(defun normexp_export_class (recv env ncx psloc)
  (debug "normexp export_class recv=" recv)
  (assert_msg "check export_class recv" (is_a recv class_source_export_class) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( 
        (sloc (unsafe_get_field :loca_location recv))
        (sxnames (unsafe_get_field :sexport_names recv))
        (bindslist (make_list discr_list))
        (nilnrep (instance class_nrep_nil
                           :nrep_loc sloc))
        (mocx (unsafe_get_field :nctx_modulcontext ncx))
        )
    (assert_msg "check mocx" (is_a mocx class_any_module_context) mocx)
    (foreach_in_multiple
     (sxnames)
     (xnam :long ix)
     (assert_msg "check xnam" (is_a xnam class_symbol) xnam)
     (let ( (xbind (find_env env xnam)) 
            (xsymdata (normal_symbol_data xnam ncx sloc))
            )
       (debug "normexp_export_class xbind" xbind)
       (assert_msg "check xsymdata" (is_a xsymdata class_nrep_datasymbol) xsymdata)
       (when (is_not_a xbind class_class_binding)
         (error_at sloc "EXPORT_CLASS with non-class-bound symbol $1"_
                   (unsafe_get_field :named_name xnam))
             (return))
       (let ( (xdata (unsafe_get_field :fixbind_data xbind)) 
              (xclass (unsafe_get_field :cbind_class xbind))
              )
         (debug "normexp_export_class xdata" xdata)
         (if (is_not_a xdata class_nrep_bound_data)
             (error_at sloc "forward defined class symbol $1 to EXPORT_CLASS"
                       (unsafe_get_field :named_name xnam)))
         (let ( (nclav (normal_exported_value xnam xdata env ncx sloc bindslist))
                )
           (debug "normexp_export_class nclav" nclav)
           (assert_msg "check xclass" (is_a xclass class_class) xclass)
           (let ( (xclfields (unsafe_get_field :class_fields xclass))
                  (expcladic (get_field :mocx_expclassdict mocx))
                  (expfldic (get_field :mocx_expfieldict mocx))
                  )
             (assert_msg "check expcladic" (is_mapstring expcladic) expcladic)
             (assert_msg "check expfldic" (is_mapstring expfldic) expfldic)
             (mapstring_putstr expcladic (unsafe_get_field :named_name xclass) xclass)
             (foreach_in_multiple
              (xclfields)
              (curfld :long ix)
              (assert_msg "check curfld" (is_a curfld class_field) curfld)
              (let ( (fldnam (unsafe_get_field :named_name curfld))
                     (fldclass (unsafe_get_field :fld_ownclass curfld)) )
                ;; export as value each field belonging to this class
                (if (== fldclass xclass)
                    (let ( (fldsym (get_symbolstr fldnam))
                           (fldbind (find_env env fldsym))
                           )
                      (assert_msg "check fldbind" (is_a fldbind class_field_binding) fldbind)
                      (let ( (fldata (unsafe_get_field :fixbind_data fldbind))
                             (field (unsafe_get_field :flbind_field fldbind))
                             (nfld (normal_exported_value fldsym fldata env ncx sloc bindslist))
                             )
                        (assert_msg "check field" (is_a field class_field) field)
                        (assert_msg "check expfldic" (is_mapstring expfldic) expfldic)
                        (mapstring_putstr expfldic (unsafe_get_field :named_name field) field)
                        (debug "normexp_export_class nfld=" nfld)
                        )))))
             ))))
     )
    (debug "normexp_export_class final nilnrep=" nilnrep " bindslist=" bindslist)
    (return nilnrep bindslist)
    ))
(install_method class_source_export_class normal_exp normexp_export_class)

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

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


;; return the normalized application to do the macro expport
(defun normal_exported_macro (sym nexp env ncx psloc bindslist)
  (debug "normal_exported_macro start sym=" sym "; psloc=" psloc
         "\n.. nexp=" nexp "\n.. env=" env)
  (assert_msg "check sym" (is_a sym class_symbol) sym)
  (assert_msg "check nexp" (is_a nexp class_nrep) nexp)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context))
  (assert_msg "check bindslist" (is_list bindslist) bindslist)
  (let ( (csymexpo (clone_symbol '_exportedm_))
         (symdata (normal_symbol_data sym ncx psloc))
         (csbuf (let ( (sb (make_strbuf discr_strbuf)) )
                  (add2sbuf_strconst sb "norm.exp.val : ")
                  (add2sbuf_string sb (unsafe_get_field :named_name sym))
                  sb))
         (scurenvbox (instance class_source_current_module_environment_reference
                               :loca_location psloc
                               :cmec_comment (strbuf2string discr_string csbuf)))
         )
    (debug "normal_exported_macro sgetcurenvbox" scurenvbox)
    (multicall 
     (ncurenvbox curenvbinds)
     (normal_exp scurenvbox env ncx psloc)
     (debug "normal_exported_macro ncurenvbox=" ncurenvbox " curenvbinds=" curenvbinds)
     (if (is_list curenvbinds) (list_append2list bindslist curenvbinds))
     (let (
           (argtup (tuple symdata nexp ncurenvbox))
           (cbind (instance class_normal_let_binding
                            :letbind_loc psloc
                            :binder csymexpo
                            :letbind_type ctype_void
                            :letbind_expr
                            (instance class_nrep_hook_call
                                      :nexpr_ctyp ctype_void
                                      :nhook_name '"HOOK_MACRO_EXPORTER"
                                      :nexpr_args argtup
                                      :nhook_called  (normal_predef hook_macro_exporter ncx
                                                                    psloc "hook_macro_exporter")
                                      :nhook_outs (tuple)
                                      :nhook_descr (hook_data hook_macro_exporter))                   
                            ))
           (syocc (instance class_nrep_locsymocc
                            :nrep_loc psloc
                            :nocc_ctyp ctype_void 
                            :nocc_symb csymexpo
                            :nocc_bind cbind) )
           )
       (debug "normal_exported_macro cbind=" cbind " syocc=" syocc)
       (list_append bindslist cbind)
       syocc
       ;;
       ))))

;;;; normalize an export_macro with an explicit expander
(defun normexp_export_macro (recv env ncx psloc)
  (debug "normexp export_macro recv=" recv " env=" debug_less env)
  (assert_msg "check export_macro recv" (is_a recv class_source_export_macro) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( 
        (sloc (unsafe_get_field :loca_location recv))
        (mname (unsafe_get_field :sexpmac_mname recv))
        (mvalexp (unsafe_get_field :sexpmac_mval recv))
        (bindslist (make_list discr_list))
        (nrepnil (instance class_nrep_nil :nrep_loc sloc))
        )
    (assert_msg "check mname" (is_a mname class_symbol) mname)
    (multicall 
     (nexp nbinds)
     (normal_exp mvalexp env ncx sloc)
     (list_append2list bindslist nbinds)
     (let ( 
           (nexpm (normal_exported_macro mname nexp env ncx sloc bindslist))
           )
       (debug "normexp_export_macro nexpm" nexpm)
       )
     (debug "normexp_export_macro final nrepnil=" nrepnil
            " bindslist=" bindslist)
     (return nrepnil bindslist)
     )))
(install_method class_source_export_macro normal_exp normexp_export_macro)

;;;; normalize an export_macro for a defmacro
(defun normexp_export_defmacro (recv env ncx psloc)
  (debug "normexp_export_defmacro recv=" recv " env=" debug_more env)
  (assert_msg "check export_defmacro recv" (is_a recv class_source_export_defmacro) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( 
        (modctx (get_field :nctx_modulcontext ncx))
        (macroenv (get_field :mocx_macroenv modctx))
        (sloc (unsafe_get_field :loca_location recv))
        (mname (unsafe_get_field :sexpmac_mname recv))
        (bindslist (make_list discr_list))
        (nrepnil (instance class_nrep_nil :nrep_loc sloc))
        )
    (assert_msg "check mname" (is_a mname class_symbol) mname)
    (debug "normexp_export_defmacro sloc=" debug_less sloc "; macroenv=" debug_more macroenv)
    (multicall 
     (nexp nbinds)
     (normal_exp mname macroenv ncx sloc)
     (list_append2list bindslist nbinds)
     (debug "normexp_export_defmacro sloc=" debug_less sloc "; nexp=" nexp " nbinds=" nbinds)
     (let ( 
           (nexpm (normal_exported_macro mname nexp macroenv ncx sloc bindslist))
           )
       (debug "normexp_export_defmacro  sloc=" debug_less sloc "; nexpm=" nexpm)
       )
     (debug "normexp_export_macro final nrepnil=" nrepnil
            " bindslist=" bindslist)
     (return nrepnil bindslist)
     )))
(install_method class_source_export_defmacro normal_exp normexp_export_defmacro)

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


;; return the normalized application to do the patmacro expport
;; sym is the symbol which is export_patmacro-ed
;; nmacroxp is the nrep of the macro expander
;; npattxp is the nrep of the pattern expander
(defun normal_exported_patmacro (sym nmacroxp npattxp env ncx psloc bindslist)
  (debug "normal_exported_patmacro start sym=" sym
         " nmacroxp=" nmacroxp " npattxp=" npattxp)
  (assert_msg "check sym" (is_a sym class_symbol) sym)
  (assert_msg "check nmacroxp" (is_a nmacroxp class_nrep) nmacroxp)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (assert_msg "check bindslist" (is_list bindslist) bindslist)
  (let ( (csymexpo (clone_symbol '_exportedpat_))
         (symdata (normal_symbol_data sym ncx psloc))
         (csbuf (let ( (sb (make_strbuf discr_strbuf)) )
                  (add2sbuf_strconst sb "norm.exp.pat : ")
                  (add2sbuf_string sb (unsafe_get_field :named_name sym))
                  sb))
         (scurenvbox (instance class_source_current_module_environment_reference
                               :loca_location psloc
                               :cmec_comment (strbuf2string discr_string csbuf)))
         )
    (debug "normal_exported_patmacro sgetcurenvbox" scurenvbox)
    (multicall 
     (ncurenvbox curenvbinds)
     (normal_exp scurenvbox env ncx psloc)
     (debug "normal_exported_patmacro ncurenvbox=" ncurenvbox
            " curenvbinds=" curenvbinds)
     (if (is_list curenvbinds) (list_append2list bindslist curenvbinds))
     (let (
           (argtup  (tuple symdata nmacroxp npattxp ncurenvbox))
           (cbind (instance class_normal_let_binding
                            :letbind_loc psloc
                            :binder csymexpo
                            :letbind_type ctype_void
                            :letbind_expr 
                            (instance class_nrep_hook_call
                                      :nexpr_ctyp ctype_void
                                      :nhook_name '"HOOK_PATMACRO_EXPORTER"
                                      :nexpr_args argtup
                                      :nhook_called  (normal_predef hook_patmacro_exporter ncx
                                                                    psloc "hook_patmacro_exporter")
                                      :nhook_outs (tuple)
                                      :nhook_descr (hook_data hook_patmacro_exporter))
                            ))
           (syocc (instance class_nrep_locsymocc
                            :nrep_loc psloc
                            :nocc_ctyp ctype_void 
                            :nocc_symb csymexpo
                            :nocc_bind cbind) )
           )
       (debug "normal_exported_patmacro cbind=" cbind " return syocc=" syocc)
       (list_append bindslist cbind)
       syocc
       ;;
       ))))

;;;;;;;;;;;;;;;;
;;;; normalize an export_patmacro
(defun normexp_export_patmacro (recv env ncx psloc)
  (debug "normexp export_patmacro recv=" recv)
  (assert_msg "check export_patmacro recv" (is_a recv class_source_export_patmacro) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let (
        (sloc (unsafe_get_field :loca_location recv))
        (mname (unsafe_get_field :sexpmac_mname recv))
        (mvalexp (unsafe_get_field :sexpmac_mval recv))
        (mpatexp (unsafe_get_field :sexppat_pval recv))
        (bindslist (make_list discr_list))
        (nrepnil (instance class_nrep_nil :nrep_loc sloc))
        )
    (debug "normexp export_patmacro mname=" mname)
    (assert_msg "check mname" (is_a mname class_symbol) mname)
    (multicall 
     (nexpmac nbindms)
     (normal_exp mvalexp env ncx sloc)
     (list_append2list bindslist nbindms)
     (debug "normexp_export_patmacro nexpmac" nexpmac)
     (multicall 
      (nexppat nbindps)
      (normal_exp mpatexp env ncx sloc)
      (list_append2list bindslist nbindps)
      (debug "normexp_export_patmacro nexppat" nexpmac)
      (let ( (nexpm (normal_exported_patmacro mname nexpmac nexppat env ncx sloc bindslist)) )
        (debug "normexp_export_patmacro nexpm=" nexpm)
        (debug "normexp_export_patmacro final nrepnil=" nrepnil " bindslist=" bindslist)
        (return nrepnil bindslist)
        )
      ))
    ))
(install_method class_source_export_patmacro normal_exp normexp_export_patmacro)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; normalize current_module_environment_reference
(defun normexp_current_module_environment_reference (recv env ncx psloc)
  (debug "normexp_current_module_environment_reference recv=" recv)
  (assert_msg "check current_module_environment_reference recv" 
              (is_a recv class_source_current_module_environment_reference) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( 
        (sloc (unsafe_get_field :loca_location recv))
        (scomm (unsafe_get_field :cmec_comment recv))
        (ncurmodenvlist (unsafe_get_field :nctx_procurmodenvlist ncx))
        (curproc (unsafe_get_field :nctx_curproc ncx))
        (qdatcur (unsafe_get_field :nctx_qdatcurmodenvbox ncx))
        (nquasi (instance class_nrep_quasiconst_current_module_environment_reference
                          :nrep_loc sloc
                          :nconst_sval recv
                          :nconst_proc curproc
                          :nconst_data qdatcur
                          :nqcmec_comment scomm
                          ))
        )
    (assert_msg "check qdatcur" (is_a qdatcur class_nrep_quasidata_current_module_environment_reference) qdatcur)
    (when (is_a curproc class_nrep_hookproc)
      (error_at sloc "(CURRENT_MODULE_ENVIRONMENT_REFERENCE) cannot be used within hooks"_)
      (return))
    (when (is_a curproc class_nrep_routproc)
          (list_append (get_field :nrclop_constlist curproc) qdatcur)
          (list_append ncurmodenvlist curproc)
          )
    (debug "normexp_current_module_environment_reference nquasi" nquasi)
    (return nquasi ())
    ))
(install_method class_source_current_module_environment_reference normal_exp normexp_current_module_environment_reference)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; normalize parent_module_environment
(defun normexp_parent_module_environment (recv env ncx psloc)
  (debug "normexp_parent_module_environment recv=" recv)
  (assert_msg "check parent_module_environment recv" (is_a recv class_source_parent_module_environment) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( 
        (sloc (unsafe_get_field :loca_location recv))
        (curproc (unsafe_get_field :nctx_curproc ncx))
        (qdatpar (unsafe_get_field :nctx_qdatparmodenv ncx))
        (nquasi (instance class_nrep_quasiconst_parent_module_environment
                          :nrep_loc sloc
                          :nconst_sval recv
                          :nconst_proc curproc
                          :nconst_data qdatpar
                          ))
        )
    (when (is_a curproc class_nrep_hookproc)
      (error_at sloc "(PARENT_MODULE_ENVIRONMENT) cannot be used within hooks"_)
      (return))
    (assert_msg "check qdatpar" (is_a qdatpar class_nrep_quasidata_parent_module_environment) qdatpar)
    (if (is_a curproc class_nrep_routproc)
        (list_append (get_field :nrclop_constlist curproc) qdatpar))
    (debug "normexp_parent_module_environment nquasi" nquasi)
    (return nquasi ())
    ))
(install_method class_source_parent_module_environment normal_exp normexp_parent_module_environment)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; normalize update_current_module_environment_reference
(defun normexp_update_current_module_environment_reference (recv env ncx psloc)
  (debug "normexp_update_current_module_environment_reference recv=" recv
         "\n env=" env
         "\n ncx=" debug_less ncx)
  (assert_msg "check update_current_module_environment_reference recv"
              (is_a recv class_source_update_current_module_environment_reference) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (shortbacktrace_dbg "normexp_update_current_module_environment_reference" 20)
  (let ( 
        (sloc (unsafe_get_field :loca_location recv))
        (scomm (unsafe_get_field :sucme_comment recv))
        (curproc (unsafe_get_field :nctx_curproc ncx))
        (iniproc (unsafe_get_field :nctx_initproc ncx))
        (modctx (unsafe_get_field :nctx_modulcontext ncx))
        (modnam  (get_field :mocx_modulename modctx))
        )
    (when (!= curproc iniproc)
          (error_at sloc "(UPDATE_CURRENT_MODULE_ENVIRONMENT_REFERENCE) not at toplevel"_)
          (return))
    (debug "normexp_update_current_module_environment_reference modctx=" 
           debug_less modctx)
    (cond ((is_a modctx class_running_extension_module_context)
           (let ( (nchk (instance class_nrep_check_running_module_environment_container
                                  :nrep_loc sloc
                                  :nchrumod_comment scomm
                                  ))
                  (csym (clone_symbol 'checkrunmodenvbox_))
                  (cbind (instance 
                          class_normal_let_binding
                          :letbind_loc sloc
                          :binder csym
                          :letbind_type ctype_void
                          ;; ctype_void because the sideffect is in nchk
                          :letbind_expr nchk))
                  (clocc (instance 
                          class_nrep_locsymocc
                          :nrep_loc sloc
                          :nocc_ctyp ctype_void
                          :nocc_symb csym
                          :nocc_bind cbind))
                  (bindlist (list cbind))
                  )
             (debug "normexp_update_current_module_environment_reference gives nchk=" nchk
                    " clocc=" clocc " bindlist=" bindlist)
             (return clocc bindlist)
             ))
          ((is_a modctx class_any_module_context)
           (assert_msg "check modctx not running" (is_not_a modctx class_running_extension_module_context) modctx)
           (let ( (nup (instance class_nrep_update_current_module_environment_reference
                                 ;; :ncumeb_expr filled later
                                 :nrep_loc sloc
                                 :ncumeb_comment scomm
                                 )) 
                  (csym (clone_symbol 'updatcurmodenvbox_))
                  (cbind (instance 
                          class_normal_let_binding
                          :letbind_loc sloc
                          :binder csym
                          :letbind_type ctype_void
                          ;; ctype_void because the sideffect is in nup
                          :letbind_expr nup))
                  (clocc (instance 
                          class_nrep_locsymocc
                          :nrep_loc sloc
                          :nocc_ctyp ctype_void
                          :nocc_symb csym
                          :nocc_bind cbind))
                  (csbuf (let ( (sb (make_strbuf discr_strbuf)) )
                           (add2sbuf_strconst sb "cur.mod.env.cont : ")
                           (add2sbuf_string sb scomm)
                           sb))
                  (scurenvbox (instance class_source_current_module_environment_reference
                                        :loca_location sloc
                                        :cmec_comment (strbuf2string discr_string csbuf)))
                  (sgetcurenvbox
                   (instance 
                    class_source_or
                    :loca_location psloc
                    :sor_disj 
                    (tuple
                     scurenvbox
                     (instance 
                      class_source_hook_call
                      :loca_location psloc
                      :shook_called hook_fresh_environment_reference_maker
                      :sargop_args (tuple
                                    (instance class_source_parent_module_environment
                                              :loca_location psloc)
                                    modnam
                                    ))
                     )))
                  )
             (multicall
              (ncurenvbox bindlist)
              (normal_exp sgetcurenvbox env ncx sloc)
              (list_append bindlist cbind)
              (unsafe_put_fields nup :nucmeb_expr ncurenvbox)
              (debug "normexp_update_current_module_environment_reference result bindlist=" bindlist" clocc=" clocc)
              (return clocc bindlist)
              )
             ))
          (:else
           (assert_msg "normexp_update_current_module_environment_reference unexpected module context" () modctx))
          )))
(install_method class_source_update_current_module_environment_reference normal_exp normexp_update_current_module_environment_reference)

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

;;;; normalize a fetch_predefined
(defun normexp_fetch_predefined (recv env ncx psloc)
  (debug "normexp_fetch_predefined recv=" recv)
  (assert_msg "check fetch_predefined recv" (is_a recv class_source_fetch_predefined) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( 
        (sloc (unsafe_get_field :loca_location recv))
        (spred (unsafe_get_field :sfepd_predef recv))
        (predefmap (unsafe_get_field :nctx_predefmap ncx))
        )
    (cond ( (is_a spred class_symbol)
            ;; if the spred is a symbol, check that it is a value in the predefmap
            (let ( (contk (reference ())) 
                   )
              (mapobject_every predefmap
                               (lambda (key val)
                                 (if (== val spred) (set_ref contk key))))
              (if (null (deref contk))
                  (warning_strv sloc "FETCH_PREDEFINED unknown predef name"
                                (unsafe_get_field :named_name spred)))
              )
            )
          ( (is_integerbox spred)
            ;; if spred is an integer, check it
            (let ( (:long predrk (get_int spred)) )
              (if (or (<=i predrk 0) (>=i predrk (last_globpredef_index)))
                  (warning_plain sloc "FETCH_PREDEFINED invalid predef rank"))
              )
            )
          (:else
           (assert_msg "FETCH_PREDEFINED bad predef" () spred))
          )
    (let ( (npre (instance class_nrep_predef
                           :nrep_loc sloc
                           :nrpredef spred
                           ))
           )
      (debug "normexp_fetch_predefined result npre" npre)
      (return npre ())
      )))
(install_method class_source_fetch_predefined normal_exp normexp_fetch_predefined)


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

;;;; normalize a store_predefined
(defun normexp_store_predefined (recv env ncx psloc)
  (debug "normexp_store_predefined recv=" recv)
  (assert_msg "check store_predefined recv" (is_a recv class_source_store_predefined) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( 
        (sloc (unsafe_get_field :loca_location recv))
        (spred (unsafe_get_field :sstpd_predef recv))
        (sval (unsafe_get_field :sstpd_value recv))
        (predefmap (unsafe_get_field :nctx_predefmap ncx))
        )
    (cond ( (is_a spred class_symbol)
            ;; if the spred is a symbol, check that it is a value in the predefmap
            (let ( (contk (reference ())) 
                   )
              (mapobject_every predefmap
                               (lambda (key val)
                                 (if (== val spred) (set_ref contk key))))
              (if (null (deref contk))
                  (warning_strv sloc "STORE_PREDEFINED unknown predef name"
                                (unsafe_get_field :named_name spred)))
              )
            )
          ( (is_integerbox spred)
            ;; if spred is an integer, check it
            (let ( (:long predrk (get_int spred)) )
              (if (or (<=i predrk 0) (>=i predrk (last_globpredef_index)))
                  (warning_plain sloc "STORE_PREDEFINED invalid predef rank"))
              )
            )
          (:else
           (assert_msg "STORE_PREDEFINED bad predef" () spred))
          )
    (multicall 
     (nval nbinds)
     (normal_exp sval env ncx sloc)
     (if (null nbinds) 
         (setq nbinds (make_list discr_list)))
     (let ( (csym (clone_symbol '_storepredef_))
            (nfpre (instance class_nrep_store_predefined
                             :nrep_loc sloc
                             :nstpd_predef spred
                             :nstpd_value nval))
            (cbind (instance class_normal_let_binding
                             :binder csym
                             :letbind_type ctype_value
                             :letbind_expr nfpre))
            (syocc (instance class_nrep_locsymocc
                             :nrep_loc sloc
                             :nocc_ctyp ctype_value
                             :nocc_symb csym
                             :nocc_bind cbind))
            )
       (list_append nbinds cbind)
       (debug "normexp_store_predefined result nbinds=" nbinds " syocc=" syocc)
       (return syocc nbinds)
       ))))
(install_method class_source_store_predefined normal_exp normexp_store_predefined)

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

;;;; normalize a cheader
(defun normexp_cheader (recv env ncx psloc)
  (debug "normexp_cheader recv=" recv "\n* ncx=" ncx)
  (assert_msg "check cheader recv" (is_a recv class_source_cheader) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( 
        (sloc (unsafe_get_field :loca_location recv))
        (modctx (get_field :nctx_modulcontext ncx))
        (mcheadlist (get_field :mocx_cheaderlist modctx))
        )
    (debug "normexp_cheader modctx=" modctx "\n.. mcheadlist=" mcheadlist
           "\n.. recv=" recv)
    (shortbacktrace_dbg "normexp_cheader" 12)
    (assert_msg "check modctx" (is_a modctx class_any_module_context) modctx)
    (assert_msg "check mcheadlist" (is_list mcheadlist) mcheadlist)
    (cppif MELT_HAVE_DEBUG
           (foreach_pair_component_in_list
            (mcheadlist)
            (curpair curhead)
            (assert_msg "check curhead != recv" (!= curhead recv) curhead
                        mcheadlist modctx))
           )
    (list_append mcheadlist recv)
    (debug "normexp_cheader updated mcheadlist=" mcheadlist "\n modctx=" modctx "\n")
    (return () ())
))
(install_method class_source_cheader normal_exp normexp_cheader)


;;;; normalize a cimplement
(defun normexp_cimplement (recv env ncx psloc)
  (debug "normexp_cimplement recv=" recv "\n* ncx=" ncx)
  (assert_msg "check cimplement recv" (is_a recv class_source_cimplement) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( 
        (sloc (unsafe_get_field :loca_location recv))
        (modctx (get_field :nctx_modulcontext ncx))
        (mcimplemlist (get_field :mocx_cimplementlist modctx))
        )
    (debug "normexp_cimplement modctx=" modctx "\n mcimplemlist=" mcimplemlist)
    (assert_msg "check modctx" (is_a modctx class_any_module_context) modctx)
    (assert_msg "check mcimplemlist" (is_list mcimplemlist) mcimplemlist)
    (list_append mcimplemlist recv)
    (debug "normexp_cimplement updated mcimplemlist=" mcimplemlist "\n modctx=" modctx "\n")
    (return () ())
))
(install_method class_source_cimplement normal_exp normexp_cimplement)


;;;; normalize a module_is_gpl_compatible
(defun normexp_module_is_gpl_compatible (recv env ncx psloc)
  (debug "normexp_module_is_gpl_compatible recv=" recv "\n* ncx=" ncx)
  (assert_msg "check module_is_gpl_compatible recv" (is_a recv class_source_module_is_gpl_compatible) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( 
        (sloc (unsafe_get_field :loca_location recv))
        (modctx (get_field :nctx_modulcontext ncx))
        (modgplcomp (get_field :mocx_isgplcompatible modctx))
        (gplcomp (get_field :sc_codestring recv))
        )
    (debug "normexp_module_is_gpl_compatible modctx=" modctx " modgplcomp=" modgplcomp " gplcomp=" gplcomp)
    (assert_msg "check modctx" (is_a modctx class_any_module_context) modctx)
    (assert_msg "check gplcomp" (is_string gplcomp) gplcomp)
    (when modgplcomp
      (assert_msg "check modgplcomp" (is_string modgplcomp))
      (warning_at sloc "duplicate MODULE_IS_GPL_COMPATIBLE, previous was $1, current is $2"
                  modgplcomp gplcomp)
      )
    (put_fields modctx :mocx_isgplcompatible gplcomp)
    (return () ())
))
(install_method class_source_module_is_gpl_compatible normal_exp normexp_module_is_gpl_compatible)


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

;;;; normalize a use_package_from_pkg_config
(defun normexp_use_package_from_pkg_config (recv env ncx psloc)
  (debug "normexp_use_package_from_pkg_config recv=" recv "\n* ncx=" ncx)
  (assert_msg "check cheader recv" (is_a recv class_source_use_package_from_pkg_config) recv)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx)
  (let ( 
        (sloc (unsafe_get_field :loca_location recv))
        (pkgtup (get_field :susepackage_pkgtuple recv))
        (modctx (get_field :nctx_modulcontext ncx))
        (mcpackagelist (get_field :mocx_packagepclist modctx))
        )
    (debug "normexp_use_package_from_pkg_config initial mcpackagelist=" mcpackagelist)
    (assert_msg "check modctx" (is_a modctx class_any_module_context) modctx)
    (assert_msg "check mcpackagelist" (is_list mcpackagelist) mcpackagelist)
    ;; append each package name only if it is not already in the list
    (foreach_in_multiple
     (pkgtup)
     (curpkgname :long pkgix)
     (debug "normexp_use_package_from_pkg_config curpkgname=" curpkgname)
     (assert_msg "check curpkgname" (is_string curpkgname) curpkgname)
     (let ( (:long found 0)
            )
       (foreach_pair_component_in_list
        (mcpackagelist)
        (curpair oldpkgname)
        (when (==s oldpkgname curpkgname)
          (setq found 1)
          (setq curpair ())))
       (unless found
         (list_append mcpackagelist curpkgname))
       )
     )
    ;;
    (debug "normexp_use_package_from_pkg_config final mcpackagelist=" mcpackagelist)
    ))
(install_method class_source_use_package_from_pkg_config normal_exp normexp_use_package_from_pkg_config)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(export_values
 check_ctype_nargs
 compile_obj
 create_normcontext
 create_normal_extending_context
 discr_normalizing_closure
 get_ctype
 normal_exp
 normal_letrec_constructive
 normal_predef
 normal_import
 normalize_binding
 normalize_tuple
 prepare_constructor_binding
 register_literal_value
 wrap_normal_let1
 wrap_normal_letseq
 )

;; compatibility with old code
(export_synonym class_nrep_data class_nrep_bound_data)
(export_synonym class_nrep_checkinterrupt class_nrep_checksignal)
(export_synonym class_nrep_quasiconst_current_module_environment_container class_nrep_quasiconst_current_module_environment_reference)
(export_synonym class_nrep_quasidata_current_module_environment_container class_nrep_quasidata_current_module_environment_reference)
(export_synonym class_nrep_update_current_module_environment_container class_nrep_update_current_module_environment_reference)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; eof warmelt-normal.melt