path: root/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" 12)
  (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))
		   )
	      (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)
  (multiple_every 
   nargs
   (lambda (cnarg :long ix) 
     (let ( (ctyp (get_ctype cnarg env)) )
       (assert_msg "check_ctype_nargs ctyp" (is_a ctyp class_ctype) ctyp)
       (if (not (is_string (unsafe_get_field :ctype_parstring ctyp)))
	   (error_at sloc "argument has invalid type $1"_ (unsafe_get_field :named_name ctyp))
	 ))
     )))


(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" 25)
  (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" 15)
  (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)
      (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))
		))
	  ))
      ;;
      (check_ctype_nargs nargs env 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)
  (debug "normexp_let" " ncx=" debug_more 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)
	    ;; 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
	      (if (== sbtyp quasi_ctype_auto)
		  (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)
  (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)
  (debug "normexp_defcmatcher recv" recv)
  (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)
		   (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
    (if (is_multiple testcma)
	(progn
	  (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
    (if (is_multiple fillcma)
	(progn
	  (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
    (if (is_multiple opercma)
	(progn
	  (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