path: root/gcc/melt/warmelt-normal.melt

;; file warmelt-normal.melt -*- Lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(comment "***
    Copyright 2008, 2009, 2010 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 file is the third 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
	   ))

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


;; 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, with a
single result. $NSEND_SEL is the normalized selector, $NSEND_RECV
the normalized reciever, with $NEXPR_ARGS giving the normalized arguments.}#
  :super class_nrep_typed_expression_with_arguments
  :fields (nsend_sel		   ;the normalized selector occurrence
	   nsend_recv		   ;the reciever
	   ))



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

(compile_warning "should add documentation below")
;; common normal for if & ifisa
(defclass class_nrep_ifcommon
  :super class_nrep_typed_expression
  :fields (nif_then
	   nif_else
	   ))

;; normal if is_a(value,class) then else
(defclass class_nrep_ifisa
  :super class_nrep_ifcommon
  :fields (nifa_val			;normal value to be tested
	   nifa_class			;normal class 
))

;; normal if have simple test, then, else clauses & a ctype
(defclass class_nrep_if
  :super class_nrep_ifcommon
  :fields (nif_test
	   ))

;; normal ifcpp have a symbol and a ctyp
(defclass class_nrep_cppif
  :super class_nrep_expression
  :fields (nifp_cond
	   nifp_then
	   nifp_else
	   nifp_ctyp
	   ))

;; normal progn has a distingished last
(defclass class_nrep_progn
  :super class_nrep_expression
  :fields (nprogn_seq			;tuple of all but last
	   nprogn_last
	   ))

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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_ANYPROC is the class for the initial
procedure in a module. Field $NINIT_TOPL is the list of top-level
normalized expressions.}#
  :fields (ninit_topl			;list of toplevel nrep
	   ))

;; normal routine procedure
(defclass class_nrep_routproc
  :super class_nrep_anyproc
  :doc #{The $CLASS_NREP_ROUTPROC is the class for normal routine
procedures, representing $DEFUN or $LAMBDA code. Field $NRPRO_NAME
is the name, field $NRPRO_ARGB is the formal arguments
binding. Field $NRPRO_CLOSEDB is the list of closed bindings. Field
$NRPRO_CONST is the list of constants. 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.}#
  :fields (
	   nrpro_name			;name (if any)
	   nrpro_argb			;argument bindings
	   nrpro_closedb		;list of closed bindings
	   nrpro_const			;list of constants
	   nrpro_datarout		;routine data object
	   nrpro_dataclos		;closure data object
	   nrpro_thunklist		;list of thunks to be called when compiling it
	   ))

(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_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
  :super class_nrep_simple
  :fields (
	   nrpredef			;the predef is a symbol or a boxed integer
	   ))

;; normalized nil
(defclass class_nrep_nil
  :super class_nrep_simple
  :fields (
	   ))


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

(defclass class_nrep_quasidata
  :super class_nrep
  :fields (
	   ))


;;;; static data is build at module initialization time
(defclass class_nrep_data
  ;; the objnum is the predefined rank if any
  :super class_nrep_quasidata
  :fields (ndata_name			;name if any of the data
	   ndata_discrx		;discriminant normal expression 
	   ndata_rank			;boxed integer rank of the data 
	   ;;; we box the integer and don't use the objnum bzcause we
	   ;;; might have a lot (>30000) of data
	   ndata_locbind		;local binding tuple to fill the data
	   ))

;; normal "static" instance - built at modules initialization
(defclass class_nrep_datainstance
  :super class_nrep_data
  :fields (ninst_objnum			;object number (a number or a symbol)
	   ninst_predef			;predefined rank (number or symbol)
	   ninst_hash			;integer hash
	   ninst_slots			;tuple of normalized slots expressions
	   ))

;; normal "static" string
(defclass class_nrep_datastring
  :super class_nrep_data
  :fields ( nstr_string		    ;the string
	    ))

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

;; normal "static" tuple
(defclass class_nrep_datatuple
  :super class_nrep_data
  :fields ( ntup_comp			;the tuple of component values expressions
	    ))

;; normal interned static symbol
(defclass class_nrep_datasymbol
  :super class_nrep_datainstance
  :fields ( ndsy_namestr
	    ))

;; normal interned static keyword
(defclass class_nrep_datakeyword
  :super class_nrep_datasymbol
  :fields ( 
	   ))

;; normal static routine data
(defclass class_nrep_dataroutine
  :super class_nrep_data
  :fields (ndrou_proc		    ;associated procedure
	   ))

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

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

;; 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_container &
;;; 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, ...)
(defclass class_nrep_constant
  :super class_nrep_quasiconstant
  :fields (
	   
	   ))

;; noormal current_module_environment_container quasiconst
(defclass class_nrep_quasiconst_current_module_environment_container
  :super class_nrep_quasiconstant
  :fields ( nqcmec_comment
	    ))


;; normal current_module_environment_container quasidata
(defclass class_nrep_quasidata_current_module_environment_container
  :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_container
  :super class_nrep_expression
  :fields (
	   nucmeb_expr			;the normalized expression
					;computing the box
	   ncumeb_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_nrep
 class_nrep_anyproc
 class_nrep_apply
 class_nrep_chunk
 class_nrep_citeration
 class_nrep_closedocc
 class_nrep_comment 
 class_nrep_constant
 class_nrep_constocc
 class_nrep_cppif
 class_nrep_data
 class_nrep_databoxedinteger
 class_nrep_dataclosure
 class_nrep_datainstance
 class_nrep_datakeyword
 class_nrep_dataroutine
 class_nrep_datastring
 class_nrep_datasymbol
 class_nrep_datatuple
 class_nrep_defunroutproc
 class_nrep_exit
 class_nrep_expression
 class_nrep_fieldacc
 class_nrep_fieldassign
 class_nrep_forever
 class_nrep_if
 class_nrep_ifcommon
 class_nrep_ifisa
 class_nrep_importedval
 class_nrep_initproc
 class_nrep_instance
 class_nrep_lambda
 class_nrep_lambdaroutproc
 class_nrep_let
 class_nrep_letrec
 class_nrep_locsymocc
 class_nrep_msend
 class_nrep_multacc
 class_nrep_multiapply
 class_nrep_multimsend
 class_nrep_nil
 class_nrep_predef
 class_nrep_progn
 class_nrep_quasiconst_current_module_environment_container
 class_nrep_quasiconst_parent_module_environment
 class_nrep_quasiconstant
 class_nrep_quasidata
 class_nrep_quasidata_current_module_environment_container
 class_nrep_quasidata_parent_module_environment
 class_nrep_return
 class_nrep_routproc
 class_nrep_setq
 class_nrep_simple
 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_put_fields
 class_nrep_update_current_module_environment_container

 )					;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)
  (assert_msg "check nctx" (is_a nctx class_normalization_context))
  (assert_msg "check ndata" (is_a ndata class_nrep_data))
  (assert_msg "fresh ndata" (null (unsafe_get_field :ndata_rank ndata)))
  (let ( (datlis (unsafe_get_field :nctx_datalist nctx)) )
    (assert_msg "check datlis" (is_list datlis))
    (let ( (lastdat (pair_head (list_last datlis)))  )
      (if (is_a lastdat class_nrep_data)
	  (let ( (:long lastrk (get_int (unsafe_get_field :ndata_rank lastdat))) )
	    (assert_msg "check lastrk" (>i lastrk 0))
	    (let ( (rkbox (make_integerbox discr_integer (+i 1 lastrk))) )
	      (unsafe_put_fields ndata :ndata_rank rkbox)
	      ))
	(let ( (rkbox1 (make_integerbox discr_integer 1)) )
	  (unsafe_put_fields ndata :ndata_rank rkbox1)
	  )))
    (list_append datlis ndata)
    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")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; create a normalization context
(defun create_normcontext (modctx)
  (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_module_context))
    (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)
			      :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_container
						  )
		 :nctx_qdatparmodenv (instance class_nrep_quasidata_parent_module_environment
					       )
		 :nctx_procurmodenvlist (make_list discr_list)
		 ))
	   )
      (debug_msg ncx "create_normcontext return ncx")
      (return ncx)
      )))


;;; the normal_exp selector 
;;;;; expected arguments: 
;;;   recv = the reciever, eg a sexpr
;;;   env = the environment 
;;;   ncx = the normalization context 
;;;   psloc = (parent) source location
;;;;; expected results: normalized + binding list 
;;; 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
					;  :named_name (stringconst2val discr_namestring "NORMAL_EXP")
  )

;; many stuff are already normalized 
(defun normexp_identical (recv env ncx psloc)
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  ;; is a no-op
  (debug_msg recv "normexp_identical recv")
  recv)

(install_method discr_any_receiver normal_exp  normexp_identical)

;; I'm not sure to understand why we need this.
(install_method discr_string normal_exp  normexp_identical)

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

;;; catchall for src
(defun normexp_src_catchall (recv env ncx psloc)
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_src_catchall recv" )
  (let ( (myclass (discrim recv))
	 (myclassname (unsafe_get_field :named_name myclass)) )
    (error_strv (unsafe_get_field :loca_location recv) 
		"unimplemented normalization for " myclassname)
    (assert_msg "normexp_src_catchall unimplemented normexp for src" ())
    ))
(install_method class_source normal_exp normexp_src_catchall)

;; the selector to compute the ctype of a value in an environment
;;; argument: environment
;;;; sometimes this selector is used with a null environment, for
;;;; instance in the code generation phase
(defselector get_ctype class_selector
					;  :named_name (stringconst2val discr_namestring "GET_CTYPE")
  )

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

(defselector compile_obj class_selector
  )

;;; 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_msg recv "gectyp_integer recv")
  ctype_long)
(install_method discr_integer get_ctype gectyp_integer)

;; strings are ctype_cstring
(defun gectyp_string (recv env)
  ctype_cstring)
(install_method discr_string get_ctype gectyp_string)

;;; normalize a tuple - returning a tuple & a bindinglist
(defun normalize_tuple (tup env ncx psloc)
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (if (null tup) (return () ()))
  (assert_msg "check tup" (is_multiple tup))
  (debug_msg tup "normalize_tuple tup" )
  (let ( (bindlist (make_list discr_list)) 
	 (res (multiple_map
	       tup 
	       (lambda (comp :long ix)
		 (debug_msg comp "normalize_tuple comp")
		 (multicall 
		  (norcomp nbinds)
		  (normal_exp comp env ncx psloc)
		  (debug_msg norcomp "normalize_tuple norcomp")
		  (debug_msg nbinds "normalize_tuple nbinds")
		  (assert_msg "check nbinds" (is_list_or_null nbinds))
		  (assert_msg "check norcomp not nrep_expr" (is_not_a norcomp class_nrep_expression))
		  (if (is_list nbinds)
		      (list_every 
		       nbinds
		       (lambda (bnd)
			 (assert_msg "check bnd" (is_a bnd class_any_binding))
			 (assert_msg "check bindlist" (is_list bindlist))
			 (list_append bindlist bnd)
			 ))		
		    )
		  norcomp
		  ))))
	 )
    (if (not (is_pair (list_first bindlist)))
	(setq bindlist ()))
    (debug_msg res "normalize_tuple res")
    (debug_msg bindlist "normalize_tuple bindlist" )
    (return res bindlist)
    ))


;; wrap a normal let around a tuple of normalized expressions and a bindinglist
(defun wrap_normal_letseq (tupnexp bindlist loc)
  (assert_msg "check tupnexp" (is_multiple_or_null tupnexp))
  (assert_msg "check bindlist" (is_list_or_null bindlist))
  (list_every
   bindlist 
   (lambda (cbind) 
     (if (not (is_a cbind class_normal_let_binding))
	 (progn
	   (debug_msg tupnexp "wrap_normal_letseq tuplexp")
	   (debug_msg bindlist "wrap_normal_letseq bindlist")
	   (debug_msg cbind "wrap_normal_letseq cbind")))
     (assert_msg "check cbind wrapnormletseq" (is_a cbind class_normal_let_binding))))
  (let ( (wnlet
	  (instance class_nrep_let
		    :nrep_loc loc
		    :nlet_bindings (list_to_multiple bindlist)
		    :nlet_body tupnexp))
	 )
    (return wnlet)))

;; wrap a normal let around a single normalized expression & a bindinglist
(defun wrap_normal_let1 (nexp bindlist loc)
  (assert_msg "check bindlist" (is_list_or_null bindlist))
  (list_every
   bindlist 
   (lambda (cbind) 
     (if (not (is_a cbind class_normal_let_binding))
	 (progn
	   (debug_msg nexp "wrap_normal_let1 nexp")
	   (debug_msg bindlist "wrap_normal_let1 bindlist")
	   (debug_msg cbind "wrap_normal_let1 cbind")))
     (assert_msg "check cbind wrapnormlet1" (is_a cbind class_normal_let_binding))))
  (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
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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))
       (if (not (is_string (unsafe_get_field :ctype_parstring ctyp)))
	   (error_strv sloc "argument has invalid type" (unsafe_get_field :named_name ctyp))
	 ))
     )))



;; for symbols which are imported from a previous environment (this
;; only happens when compiling stuff which is not this warmelt-*) 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_msg recv "normexp_symbol recv")
  (multicall
   (bind procs)
   (find_enclosing_env env recv)
   (debug_msg bind "normexp_symbol after find_enclosing_env bind")
   (debug_msg procs "normexp_symbol after find_enclosing_env procs")
   (assert_msg "normexp_symbol check recv" (is_a recv class_symbol))
   (if (null bind)
       (progn
	 (error_strv psloc "unbound symbol to normalize"
		     (unsafe_get_field :named_name recv))
	 (return ())))
   (if (null psloc)
       (shortbacktrace_dbg "normex_symbol null psloc" 10)
     )
   (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx))
	  (syca (mapobject_get sycmap recv)) )
     (assert_msg "check sycmap" (is_mapobject sycmap))
     (cond 
      ;; check if in the cache
      (syca syca)	     ;already cached
      ;; value binding, get/put it into the map
      ( (is_a bind class_value_binding)
	(let ( (bvar (mapobject_get (unsafe_get_field :nctx_valbindmap ncx) bind)) )
	  (debug_msg bind "normexp_symbol value bind")
	  (debug_msg procs "normexp_symbol value procs")
	  (if (null bvar)
	      (let ( (newbvar 
		      (instance class_nrep_importedval
				:nrep_loc psloc
				:nimport_symb recv
				:nimport_sydata (normal_symbol_data recv ncx psloc))) )
		(mapobject_put (unsafe_get_field :nctx_valbindmap ncx) bind newbvar)
		(setq bvar newbvar)
		(list_append (unsafe_get_field :nctx_valuelist ncx) newbvar)
		))
	  ;; if procs ia non-empty list, symbol is a "closed" constant for the value
	  (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_msg fxocc "normexp_symbol const value fxocc")
		;; put the const occurrence if needed in the const list of each proc
		(list_every
		 procs
		 (lambda (pr)
		   (assert_msg "check pr" (is_a pr class_nrep_anyproc))
		   (let ( (clbox (make_box discr_box fxocc))
			  (cnstproc (unsafe_get_field :nrpro_const pr)) )
		     (list_every 
		      cnstproc
		      (lambda (cx) (if (== cx fxocc) (progn (box_put clbox ()) ()))))
		     (let ( (newcl (box_content clbox)) )
		       (if newcl (list_append cnstproc newcl))) 
		     )))
		fxocc
		)
	    ;; otherwise symbol is the direct value
	    (progn
	      ;; cache the result
	      (mapobject_put sycmap recv bvar)
	      (debug_msg bvar "normexp_symbol local value bvar")
	      bvar
	      )
	    )))
      ;; the procs is a non-empty list, so the symbol is closed
      ( (and (is_list procs)
	     (is_pair (list_first procs)))
	(debug_msg procs "normexp_symbol closed procs")
	(debug_msg bind "normexp_symbol closed 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_strv psloc
			      "closed variable has non value type (boxing required)"
			      (unsafe_get_field :named_name recv)
			      )))
	  (setq bty ctype_value)
	  (if (is_a bind class_fixed_binding)
	      (let ( (fxocc
		      (instance class_nrep_constocc
				:nrep_loc psloc
				:nocc_symb recv
				:nocc_bind bind
				:nocc_ctyp ctype_value
				:ncloc_procs procs)) )
		;; cache the result
		(mapobject_put sycmap recv fxocc)
		(debug_msg fxocc "normexp_symbol fxocc")
		;; put the const occurrence if needed in the const list of each proc
		(list_every
		 procs
		 (lambda (pr)
		   (assert_msg "check pr" (is_a pr class_nrep_anyproc))
		   (let ( (clbox (make_box discr_box fxocc))
			  (cnstproc (unsafe_get_field :nrpro_const pr)) )
		     (list_every 
		      cnstproc
		      (lambda (cx) (if (== cx fxocc) (progn (box_put clbox ()) ()))))
		     (let ( (newcl (box_content clbox)) )
		       (if newcl (list_append cnstproc newcl))) 
		     )))
		fxocc
		)
	    (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)
	      ;; put the closed occurrence if needed in the closed list of each proc
	      (list_every 
	       procs
	       (lambda (pr)
		 (assert_msg "check pr" (is_a pr class_nrep_anyproc))
		 (let ( (clbox (make_box discr_box clocc))
			(clobindl (unsafe_get_field :nrpro_closedb pr)) )
		   (list_every 
		    clobindl
		    (lambda (clbnd) (if (== clbnd bind) (progn (box_put clbox ()) ()))))
		   (let ( (newcl (box_content clbox)) )
		     (if newcl (list_append clobindl bind))) 
		   )))
	      clocc
	      ) ) ) ) 
      ;; formal arg is a local
      ( (is_a bind class_formal_binding)
	(let ( (syocc
		(instance class_nrep_locsymocc
			  :nrep_loc psloc
			  :nocc_ctyp (unsafe_get_field :fbind_type bind) 
			  :nocc_symb recv
			  :nocc_bind bind) ) )
	  ;; cache the result & return it
	  (mapobject_put sycmap recv syocc)
	  syocc
	  ))
      ;; let binding is a local
      ( (is_a bind class_let_binding)
	(let ( (syocc
		(instance class_nrep_locsymocc
			  :nrep_loc psloc
			  :nocc_ctyp (unsafe_get_field :letbind_type bind)
			  :nocc_symb recv
			  :nocc_bind bind) ) )
	  ;; cache the result & return it
	  (mapobject_put sycmap recv syocc)
	  syocc
	  ))
      ;; handle fixed bindings (like defun definstance defciterator defclass ....)
      ( (is_a bind class_fixed_binding)
	(debug_msg bind "normexp_symbol fixed_binding")
	(let ( (fixdat (unsafe_get_field :fixbind_data bind)) )
	  (if (null fixdat)
	      (error_strv psloc "unresolved forward fixed reference to"
			  (unsafe_get_field :named_name recv)
			  )
	    )
	  (debug_msg fixdat "normexp_symbol fixdat")
	  (assert_msg "normexp_symbol check fixdat" (is_a fixdat class_nrep_data))
	  ;; cache the result & return it
	  (mapobject_put sycmap recv fixdat)
	  fixdat)
	)
      ;; handle letrec constructed bindings...
      ( (is_a bind class_normal_constructor_binding)
	(debug_msg bind "normexp_symbol constructed bind")
	(debug_msg procs "normexp_symbol constructed procs")
	(debug_msg env "normexp_symbol constructed in env")
	(debug_msg recv "normexp_symbol constructed for recv")
	(let ( 
	      (nletrec (get_field :nconsb_nletrec bind))
	      )
	  (debug_msg nletrec "normexp_symbol nletrec")
	  (assert_msg "normexp_symbol check nletrec" (is_a nletrec class_nrep_letrec))
	  (let ( (nlocsyms (get_field :nletrec_locsyms nletrec))
		 (ourlocsym ())
		 )
	    (debug_msg nlocsyms "normexp_symbol nlocsyms")
	    ;; find the right locsym in nlocsyms and cache it
	    (foreach_in_multiple
	     (nlocsyms)
	     (curlocsym :long syix)
	     (if (== (get_field :nocc_bind curlocsym) bind)
		 (progn
		   (setq syix -99)	;to exit the loop [-1 don't work!]
		   (setq ourlocsym curlocsym)))
	     )
	    (debug_msg ourlocsym "normexp_symbol ourlocsym")
	    (assert_msg "normexp_symbol should have ourlocsym"
			(is_a ourlocsym class_nrep_locsymocc))
	    ;; cache the result & return it
	    (mapobject_put sycmap recv ourlocsym)
	    (return ourlocsym)
	    )))
      ;; all other cases are constants, probably unusual, so we warn
      (:else 
       (debug_msg bind "normexp_symbol const? bind")
       (warning_strv psloc "bizarre?? constant reference to"
		     (unsafe_get_field :named_name recv))
       (let ( (kocc
	       (instance class_nrep_constocc
			 :nrep_loc psloc
			 :nocc_ctyp ctype_value
			 :nocc_symb recv
			 :nocc_bind bind) ) )
	 (debug_msg kocc "normexp_symbol kocc" )
	 ;; cache the result & return it
	 (mapobject_put sycmap recv kocc)
	 ;; put the const occurrence if needed in the const list of each proc
	 (list_every
	  procs
	  (lambda (pr)
	    (debug_msg pr "normexp_symbol const pr")
	    (assert_msg "check pr" (is_a pr class_nrep_anyproc))
	    (let ( (clbox (make_box discr_box kocc))
		   (constproc (unsafe_get_field :nrpro_const pr)) )
	      (list_every 
	       constproc
	       (lambda (cl) (if (== cl kocc) (progn (box_put clbox ()) ()))))
	      (let ( (newcl (box_content clbox)) )
		(if newcl (list_append constproc newcl))) 
	      )))
	 kocc
	 ))))))

(install_method class_symbol normal_exp normexp_symbol)


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


;;; normalize a 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_msg recv "normexp_class recv")
  (assert_msg "check recv" (is_a recv class_class))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (let ( (clasymb (get_symbolstr (unsafe_get_field :named_name recv))) 
	 (clabind (find_env env clasymb))
	 )
    (debug_msg clabind "normexp_class clabind")
    (cond ( (is_a clabind class_class_binding)
	    (let ( (normcla (normexp_symbol clasymb env ncx psloc)) )
	      (debug_msg normcla "normexp_class normcla class data inst")
	      (assert_msg "check normcla" 
			  (or 
			   (is_a normcla class_nrep_datainstance)
			   (is_a normcla class_nrep_constocc)
			   ))
	      (return normcla)
	      ))
	  ( (is_a clabind class_value_binding)
	    (assert_msg "check clabind value" (== recv (unsafe_get_field :vbind_value clabind)))
	    (let ( (normcla (normexp_symbol clasymb env ncx psloc)) )
	      (debug_msg normcla "normexp_class normcla class value")
	      ;; normcla can be a class_nrep_constocc or a class_nrep_importedval ...
	      (assert_msg "check normcla" (is_a normcla class_nrep))
	      (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_strv psloc "class incorrectly bound, perhaps locally rebound"
		       (unsafe_get_field :named_name recv))
	   (debug_msg () "normexp_class failed")
	   (return)
	   ))
    ))

(install_method class_class normal_exp normexp_class)



;;; normalize a primitive invocation
(defun normexp_primitive (recv env ncx psloc)
  (debug_msg recv "normexp_primitive recv")
  (assert_msg "check prim recv" (is_a recv class_source_primitive))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (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))
    (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))
       (if (!=i nbarg (multiple_length sopformals))
	   (progn
	     (error_strv sloc "length mismatch between formals & actuals in primitive" 
			 sopnamstr)
	     (return ()))
	 )
       (let ( (bmap (make_mapobject  discr_map_objects (+i 5 (/iraw (*i 3 nbarg) 2))))
	      (expargs (make_multiple discr_multiple nbexp))
	      )
	 (multiple_every
	  sopformals
	  (lambda (forb :long ix)
	    (assert_msg "check forb" (is_a forb class_formal_binding))
	    (debug_msg forb "normexp_primitive 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_msg actarg "normexp_primitive actarg")
	      (debug_msg actype "normexp_primitive actype")
	      (if (and (is_a fortype class_ctype)
		       (is_a actype class_ctype)
		       (!= fortype actype))
		  (progn
		    (error_strv sloc "type mismatch between formals & actuals in primitive"
				  sopnamstr)
		    (inform_strv sloc "mismatched primitive formal name"
				 (unsafe_get_field :named_name forarg))
		    (inform_strv sloc "mismatched primitive actual type"
				 (unsafe_get_field :named_name actype))
		    (inform_strv sloc "mismatched primitive expected type"
				 (unsafe_get_field :named_name fortype))
		    ))
	      (mapobject_put bmap forarg actarg)
	      )))
	 (debug_msg bmap "normexp_primitive bmap in sopexp")
	 (multiple_every
	  sopexp
	  (lambda (excu :long jx)
	    ;;(debug_msg excu "normexp_primitive excu in sopexp")
	    (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_msg recv "normexp_primitive recv unexpected symbol in expansion")
				(debug_msg excu "normexp_primitive excu")
				(error_strv sloc "unexpected symbol in primitive expansion" 
					    (unsafe_get_field  :named_name excu))
				(error_strv sloc "bad primitive name" 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)))
		    ))
					;(debug_msg exval "normexp_primitive exval in sopexp")
	      (multiple_put_nth expargs jx exval))
	    ))
	 (debug_msg soper "normexp_primitive soper")
	 (assert_msg "check soper is named" (is_a soper class_named))
	 (let ( (csym (clone_symbol soper)) 
		(cbind (instance class_normal_let_binding
				 :letbind_loc sloc
				 :binder csym
				 :letbind_type soptype 
				 :letbind_expr 
				 (instance class_nrep_chunk
					   :nrep_loc sloc
					   :nchunk_expansion expargs
					   :nchunk_oper soper
					   :nexpr_ctyp soptype
					   ))) 
		(clocc (instance class_nrep_locsymocc
				 :nrep_loc sloc
				 :nocc_ctyp soptype
				 :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_msg clocc "normexp_primitive result clocc")
	   (return
	    clocc
	    nbind
	    )))))))

(install_method class_source_primitive normal_exp normexp_primitive)




;;; normalize a code_chunk
(defun normexp_code_chunk (recv env ncx psloc)
  (debug_msg recv "normexp_code_chunk recv")
  (assert_msg "check code_chunk recv" (is_a recv class_source_codechunk))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (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))
	 (csymstr (let ( (sbuf (make_strbuf discr_strbuf)) )
		    (add2sbuf_string sbuf (get_field :named_name csym))
		    (add2sbuf_strconst sbuf "__")
		    (add2sbuf_longdec sbuf (get_int (get_field :csym_urank csym)))
		    (strbuf2string discr_verbatim_string sbuf)
		    ))
	 (nchk (multiple_map 
		schk
		(lambda (curcomp :long curix)
		  (cond
		   ( (is_string curcomp) curcomp)
		   ( (== curcomp gsym) csymstr)
		   ( (is_a curcomp class_symbol)
		     (normal_exp curcomp env ncx sloc))
		   (:else
		    (assert_msg "impossible curcomp in src code_chunk" ()))
		   ))))
	 (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_msg clocc "normexp_code_chunk clocc")
    (assert_msg "check nchk" (is_multiple nchk))
    (return clocc (list cbind))
    ))
(install_method class_source_codechunk normal_exp normexp_code_chunk)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; normalize a cmatchexpr
(defun normexp_cmatchexpr (recv env ncx psloc)
  (debug_msg recv "normexp_cmatchexpr recv")
  (assert_msg "check recv" (is_a recv class_source_cmatchexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (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))
    (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))
	    ;; 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))
       (if (!=i nbarg (multiple_length oformals))
	   (progn
	     (error_strv sloc "length mismatch between formals & actuals in cmatch 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))
	    (debug_msg forb "normexp_cmatchexpr 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_msg actarg "normexp_cmatchexpr actarg")
	      (debug_msg actype "normexp_cmatchexpr actype")
	      (if (and (is_a fortype class_ctype)
		       (is_a actype class_ctype)
		       (!= fortype actype))
		  (progn
		    (error_strv sloc "type mismatch between formals & actuals in cmatch oper"
				  cmanamstr)
		    (inform_strv sloc "mismatched primitive formal name"
				 (unsafe_get_field :named_name forarg))
		    (inform_strv sloc "mismatched primitive actual type"
				 (unsafe_get_field :named_name actype))
		    (inform_strv sloc "mismatched primitive expected type"
				 (unsafe_get_field :named_name fortype))
		    ))
	      (mapobject_put bmap forarg actarg)
	      )))
	 (debug_msg bmap "normexp_cmatchexpr bmap in sopexp")
	 (multiple_every
	  sopexp
	  (lambda (excu :long jx)
	    ;;(debug_msg excu "normexp_cmatchexpr excu in sopexp")
	    (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_msg recv "normexp_cmatchexpr recv unexpected symbol in expansion")
				(debug_msg excu "normexp_cmatchexpr excu")
				(error_strv sloc "unexpected symbol in cmatch expression expansion" 
					    (unsafe_get_field  :named_name excu))
				(error_strv sloc "bad primitive name" 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_msg exval "normexp_cmatchexpr exval in sopexp")
	      (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_msg clocc "normexp_cmatchexpr result clocc")
	   (return
	    clocc
	    nbind
	    )))))))

(install_method class_source_cmatchexpr normal_exp normexp_cmatchexpr)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; normalize a funmatchexpr
(defun normexp_funmatchexpr (recv env ncx psloc)
  (debug_msg recv "normexp_funmatchexpr recv")
  (assert_msg "check recv" (is_a recv class_source_funmatchexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (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))
    (assert_msg "check sfbind" (is_a sfbind class_any_binding))
    (debug_msg sfbind "normexp_funmatchexpr sfbind")
    (let ( (fmatsym (unsafe_get_field :binder sfbind)) )
      (assert_msg "check fmatsym" (is_a fmatsym class_symbol))
      (assert_msg "check good sfbind" (== sfbind (find_env env fmatsym)))
      (let ( (nfmat (normal_exp fmatsym env ncx psloc)) )
	(debug_msg nfmat "normexp_funmatchexpr 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_msg nargs "normexp_funmatchexpr nargs")
	   (debug_msg nargbind "normexp_funmatchexpr 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_msg calocc "normexp_funmatchexpr final calocc")
	     (debug_msg nbind "normexp_funmatchexpr finale nbind")
	     (return calocc nbind)
	     )))))))
(install_method class_source_funmatchexpr normal_exp normexp_funmatchexpr)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; normalize an application
(defun normexp_apply (recv env ncx psloc)
  (assert_msg "check apply recv" (is_a recv class_source_apply))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (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_))
	 )
    (multicall 
     (nfun nbindfun)
     (normal_exp sfun env ncx sloc)
     (assert_msg "check nbindfun" (is_list_or_null nbindfun))
     (multicall
      (nargs nbindargs)
      (normalize_tuple sargs env ncx sloc)
      (assert_msg "check nbindargs" (is_list_or_null nbindargs))
      (check_ctype_nargs nargs env sloc)
      (setq nbindargs (list_append2list nbindargs nbindfun))
      (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
				)) 
	     )
	(if (not (is_list nbindargs))
	    (setq nbindargs (make_list discr_list)))
	(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)
  (assert_msg "check msnd" (is_a msnd class_source_msend))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg msnd "normexp_msend msnd")
  (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_msg curproc "normexp_msend curproc")
    (debug_msg selbind "normexp_msend 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))
     ;; check that reciever is a value
     (let ( (ctypr (get_ctype nrecv env)) )
       (assert_msg "normexp_msend check ctypr " (is_a ctypr class_ctype))
       (if (!= ctypr ctype_value)
	   (error_strv sloc "non value reciever for message send of selector"
		       (unsafe_get_field :named_name selnam)))
       )
     (multicall
      (nargs nbindargs)
      (normalize_tuple msargs env ncx sloc)
      (assert_msg "check nbindargs" (is_list_or_null nbindargs))
      (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))
			(get_field  :sel_signature valsel))
		      )
		    (:else 
		     (assert_msg "invalid 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_msg nsend "normexp_msend nsend middle")
	(assert_msg "check nrecv" (is_object nrecv))
	(if (is_multiple selformals)
	    (let ( (recvformal (multiple_nth selformals 0))
		   (:long nbformals (multiple_length selformals))
		   )
	      (debug_msg selformals "normexp_msend")
	      (assert_msg "check recvformal" (== (get_field :fbind_type recvformal) ctype_value))
	      (if (!=i nbformals (+i 1 (multiple_length nargs)))
		  (warning_strv sloc "unexpected number of arguments for method"
				(get_field :named_name selnam))
		)
	      (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))
		 (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_msg nbindrecv "normexp_msend final nbindrecv")
	(debug_msg clocc "normexp_msend clocc")
	(return clocc nbindrecv)
	)))))
(install_method class_source_msend normal_exp normexp_msend)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; normalize a return
(defun normexp_return (recv env ncx psloc)
  (debug_msg recv "normexp_return recv")
  (assert_msg "check return recv" (is_a recv class_source_return))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (let ( (sloc (unsafe_get_field :loca_location recv)) 
	 (srets (unsafe_get_field :sargop_args recv))
	 (:long nbrets (multiple_length srets))
	 (csym (clone_symbol '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 ctype_value 
			  ;; :letbind_expr is filled later
			  ))
	 (clocc (instance class_nrep_locsymocc
			  :nrep_loc sloc
			  :nocc_ctyp ctype_value
			  :nocc_symb csym
			  :nocc_bind cbind)) 
	 )
    ;; 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_msg clocc "normexp_return empty; return clocc")
	  (debug_msg nbindemp "normexp_return empty; return nbindemp")
	  (return clocc nbindemp))
      (multicall
       (nrets nbindrets)
       (normalize_tuple srets env ncx sloc)
       (let ( (nret0 (multiple_nth nrets 0))
	      (toth (make_multiple discr_multiple (-i nbrets 1))) 
	      (ctyp0 (get_ctype nret0 env))
	      )
	 (if (!= ctyp0 ctype_value)
	     (error_plain sloc "main return is not a value"))
	 (if (null nbindrets) 
	     (setq nbindrets (make_list discr_list)))
	 (multiple_every
	  nrets
	  (lambda (ncomp :long ix)
	    (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_msg clocc "normexp_return result nret")
	   (debug_msg nbindrets "normexp_return result 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))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_if 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))
	 )
    (multicall 
     (ntest nbindif)	     ;nbindif is also the whole result binding
     (normal_exp stest env ncx sloc)
     (assert_msg "check nbindif test" (is_list_or_null nbindif))
     (debug_msg ntest "normexp_if ntest")
     ;; 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_msg nthen "normexp_if nthen")
      (assert_msg "check nbindthen" (is_list_or_null 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_msg clocc "normexp_if result clocc")
	  (debug_msg nbindif "normexp_if result nbindif")
	  (return clocc nbindif)
	  ))
      ))))
(install_method class_source_if normal_exp normexp_if)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; normalize an ifelse
(defun normexp_ifelse (recv env ncx psloc)
  (assert_msg "check if recv" (is_a recv class_source_ifelse))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_ifelse 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))
	 (selse (unsafe_get_field :sif_else recv))
	 )
    (multicall 
     (ntest nbindif)	     ;nbindif is also the whole result binding
     (normal_exp stest env ncx sloc)
     (debug_msg ntest "normexp_ifelse ntest")
     (assert_msg "check nbindif test" (is_list_or_null nbindif))
     ;; 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_msg nthen "normexp_ifelse nthen")
      (assert_msg "check nbindthen" (is_list_or_null 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))
	(multicall 
	 (nelse nbindelse)
	 (normal_exp selse env ncx sloc)
	 (debug_msg nelse "normexp_ifelse nelse")
	 (assert_msg "check nbindelse" (is_list_or_null 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)) )
	   (assert_msg "check ctypif" (is_a ctypif class_ctype))
	   (assert_msg "check ctypelse" (is_a ctypelse class_ctype))
	   (cond
	    ( (== ctypif ctypelse)
	      ()
	      )
	    ( (and (!= ctypif ctype_void) (== ctypelse ctype_void))
	      () ;; ctypif is correct
	      )
	    ( (and (== ctypif ctype_void) (!= ctypelse ctype_void))
	      (setq ctypif ctypelse)
	      )
	    (:else
	     (warning_plain sloc 
			    "incompatible types in conditional IF/OR/COND branches")
	     (warning_strv sloc "then type in conditional is "
			   (unsafe_get_field :named_name ctypif))
	     (warning_strv sloc "else type in conditional is "
			   (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_msg clocc "normexp_ifelse result clocc")
	   (debug_msg nbindif "normexp_ifelse result 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))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_cppif 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_msg nthen "normexp_cppif nthen")
     (assert_msg "check nbindthen" (is_list_or_null 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))
       ;; normalize the else-part
       (multicall 
	(nelse nbindelse)
	(normal_exp selse env ncx sloc)
	(debug_msg nelse "normexp_cppif nelse")
	(assert_msg "check nbindelse" (is_list_or_null nbindelse))
	(let ( (newelseenv (fresh_env env)) )
	  (list_every 
	   nbindelse
	   (lambda (b) (put_env newelseenv b)))
	  (let ( (ctypelse (get_ctype nelse newelseenv)) )
	    (if (and (!= ctypif ctypelse) (!= ctypif ctype_void) (!= ctypelse ctype_void))
		(progn
		  (error_plain sloc "CPPIF incompatible then & else types")
		  (error_strv sloc "CPPIF incompatible then type :" 
			      (unsafe_get_field :named_name ctypif))
		  (error_strv sloc "CPPIF incompatible else type :" 
			      (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_msg clocc "normexp_cppif result clocc")
	      (debug_msg nbindres "normexp_cppif result 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))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_or recv")
  (let ( 
	(boxorcount (make_integerbox discr_integer (the_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))
	(norbox (make_box discr_box ()))
	(nbindorbox (make_box discr_box (make_list discr_list)))
	(ctyporbox (make_box discr_box ctype_void))
	(newenv (fresh_env env))
	)
    (multiple_backward_every 
     sdisj
     (lambda (scur :long six)
       (debug_msg scur "normexp scur" (get_int boxorcount))
       (multicall
	(ncur nbind)
	(normal_exp scur env ncx sloc)
	(debug_msg ncur "normexp ncur" (get_int boxorcount))
	(list_every ncur
		    (lambda (bnd) (put_env newenv bnd)))
	(if (null (box_content norbox))
	    (progn
	      (box_put nbindorbox nbind)
	      (box_put norbox ncur) 
	      (box_put ctyporbox (get_ctype ncur newenv))
	      ()
	      )
	  (let ( (ctypcur (get_ctype ncur newenv))
		 )
	    (assert_msg "check ctypcur" (is_a ctypcur class_ctype))
	    (if (!= ctypcur (box_content ctyporbox))
		(error_plain  sloc "disjuncts' type mismatch in OR | COND"))
	    (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 (box_content norbox) (box_content nbindorbox) 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))
		  )
	      (box_put nbindorbox (make_list discr_list))
	      (list_append2list (box_content nbindorbox) nbind)
	      (list_append (box_content nbindorbox) corbind)
	      (box_put norbox corocc)
	      ()
	      )
	    )
	  )
	)
       )
     )
    (debug_msg (box_content norbox) "normexp_or result nor")
    (debug_msg (box_content nbindorbox) "normexp_or result nbindor")
    (return (box_content norbox) (box_content nbindorbox))
    )
  )
(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))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_progn 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_plain sloc "empty PROGN")
	  (debug_msg onull "normexp_progn return empty onull")
	  (return onull)))
    (multicall
     (nbody nbind)
     (normalize_tuple sbody env ncx sloc)
     (debug_msg nbody "normexp_progn nbody")
     (debug_msg nbind "normexp_progn 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_msg nallbutlast "normexp_progn 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_msg clocc "normexp_progn return clocc")
	 (debug_msg nbind "normexp_progn return 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)
  (assert_msg "check let recv" (is_a recv class_source_let))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_let recv")
  (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))
	 )
    (multiple_every 
     sbindings
     (lambda (sb :long sbix)
       (assert_msg "check sb" (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)) 
	      )
	 ;; 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)
	  (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)
		  ))
	      ))))
       ))
;;; end of loop on source bindings
    (multicall
     (nbody nbodbindings)
     (normalize_tuple sbody newenv ncx sloc)
     (list_append2list bindlist  nbodbindings)
     (assert_msg "normexp_let check bindlist" (is_list_or_null bindlist))
     (list_every
      bindlist
      (lambda (cbnd) 
	(assert_msg "normexp_let check cbnd" (is_a cbnd class_normal_let_binding))))
;;; remove every locally bound symbol from the symbol cache map
     (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx)) )
       (list_every bindlist 
		   (lambda (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 '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_msg clocc "normexp_let result clocc")
       (debug_msg resbinds "normexp_let result 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)
  (assert_msg "check unsafegetfield recv" (is_a recv class_source_unsafe_get_field))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp unsafeget 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))
    (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_msg clocc "normexp unsafeget result clocc")
       (debug_msg nbind "normexp unsafeget result 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))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_get_field 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))
    (multicall
     (nobj nbind)
     (normal_exp sobj env ncx sloc)
     (if (null nbind) (setq nbind (make_list discr_list)))
     (debug_msg nobj "normexp_get_field 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_msg nc "normexp_get_field ncla")
		    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
				       :nifa_val 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_msg clocc "normexp_get_field clocc")
       (debug_msg nbind "normexp_get_field 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))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_unsafe_put_fields 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))
	 (nbindlist (make_list discr_list)) 
	 (csym (clone_symbol 'unsafput_))
	 (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))
	(let ( (fld (unsafe_get_field :sfla_field fla))
	       (exp (unsafe_get_field :sfla_expr fla)) )
	  (assert_msg "check fld" (is_a fld class_field))
	  (multicall
	   (nexp nexpbind)
	   (normal_exp exp env ncx sloc)
	   (list_append2list nbindlist  nexpbind)
	   (let ( (nfla (instance class_nrep_fieldassign
				  :nrep_loc sloc
				  :nfla_field fld
				  :nfla_val nexp)) )
	     (multiple_put_nth nfields ix nfla)
	     )))))
     (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_msg clocc "normexp_unsafe_put_fields result clocc")
       (debug_msg nbindlist "normexp_unsafe_put_fields result 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))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_put_fields 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))
	 (nbindlist (make_list discr_list)) 
	 (csym (clone_symbol 'putfld_))
	 (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))
	 (clabox (make_box discr_box ()))
	 )
    (multicall
     (nobj nobjbind)
     (normal_exp sobj env ncx sloc)
     (list_append2list nbindlist  nobjbind)
     (foreach_in_multiple 
      (sfields)
      (fla :long ix) 
      (debug_msg fla "normexp_put_fields fla")
      (debug_msg clabox "normexp_put_fields clabox")
      (assert_msg "check fla" (is_a fla class_source_fieldassign))
      (let ( (fld (unsafe_get_field :sfla_field fla))
	     (exp (unsafe_get_field :sfla_expr fla)) )
	(assert_msg "check fld" (is_a fld class_field))
	(let ( (fcla (unsafe_get_field :fld_ownclass fld)) 
	       (precla (box_content clabox))
	       )
	  (cond ( (null precla)
		  (box_put clabox fcla)
		  )
		( (== precla fcla)
		  ()
		  )
		( (subclass_of precla fcla)
		  ()
		  )
		( (subclass_of fcla precla)
		  (box_put clabox fcla)
		  )
		(:else
		 (debug_msg fld "normexp_put_fields bad fld")
		 (debug_msg fcla "normexp_put_fields bad fcla")
		 (debug_msg precla "normexp_put_fields bad precla")
		 (error_strv sloc "bad field name in PUT_FIELD" (unsafe_get_field :named_name fld))
		 (inform_strv sloc "PUT_FIELD expecting field of class" (unsafe_get_field :named_name precla))
		 (inform_strv sloc "PUT_FIELD got field of class" (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)) )
	   (multiple_put_nth nfields ix nfla)
	   ))))
     (let (
	   (ncla (normal_exp (box_content clabox) 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
			  :nifa_val nobj
			  :nifa_class ncla
			  :nif_then npuf
			  :nexpr_ctyp ctype_void
			  )
		))
       (unsafe_put_fields cbind :letbind_expr nif)
       (list_append nbindlist cbind)
       (debug_msg clocc "normexp_put_fields result clocc")
       (debug_msg nbindlist "normexp_put_fields result 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)
  (assert_msg "check setq recv" (is_a recv class_source_setq))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp setq recv")
  (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))
    (let ( (nvar (normexp_symbol svar env ncx sloc)) 
	   (varctyp (get_ctype nvar env))
	   )
      (debug_msg varctyp "normexp_setq varctyp")
      (assert_msg "check varctyp" (is_a varctyp class_ctype))
      (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_msg expctyp "normexp_setq expctyp")
	 (assert_msg "check expctyp" (is_a expctyp class_ctype))
	 (if (!= varctyp expctyp)
	     (progn
	       (error_strv sloc "incompatible type for SETQ"
			   (unsafe_get_field :named_name svar))
	       (inform_strv sloc "left [var] type for incomatible SETQ"
			    (unsafe_get_field :named_name varctyp))
	       (inform_strv sloc "right [expr] type for incomatible SETQ"
			    (unsafe_get_field :named_name expctyp))
	       )))
       (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))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_instance 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)))
	 (bindlist (make_list discr_list))
	 )
    (if (not (is_a cladata class_nrep))
	(progn
	  (error_strv sloc "invalid class in (INSTANCE ..)" (unsafe_get_field :named_name sclass))
	  (return ())))
    (let ( (nfields 
	    (multiple_map 
	     sfields 
	     (lambda (curflda :long curk)
	       (assert_msg "check curflda" (is_a curflda class_source_fieldassign))
	       (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)
		  (assert_msg "check nbind" (is_list_or_null nbind))
		  (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_msg clocc "normexp_instance result clocc")
      (debug_msg bindlist "normexp_instance result 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))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_forever 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))
    (put_env newenv slbind)
    (let ( (resy (clone_symbol (unsafe_get_field :binder slbind))) )
      (debug_msg resy "normexp_forever putting resy..")
      (debug_msg slbind "..normexp_forever in slbind")
      (assert_msg "check resy obj1" (is_object resy))
      (unsafe_put_fields slbind :labind_clonsy resy)
      (debug_msg slbind "normexp_forever updated slbind")
      (debug_msg resy "normexp_forever clonsy put resy")
      (assert_msg "check resy" (is_a resy class_cloned_symbol))
      (debug_msg (unsafe_get_field :labind_clonsy slbind) "normexp_forever got1 clonsy")
      (assert_msg "check did1 put resy" (== (unsafe_get_field :labind_clonsy slbind) resy))
      (assert_msg "check resy obj2" (is_object resy))
      (multicall
       (nbody nbodbindings)
       (normalize_tuple sbody newenv ncx sloc)
       (debug_msg slbind "normexp_forever again slbind")
       (assert_msg "check did2 put resy" (== (unsafe_get_field :labind_clonsy slbind) resy))
       (debug_msg (unsafe_get_field :labind_clonsy slbind) "normexp_forever got2 clonsy")
       (assert_msg "check size slbind" (<i (get_int labind_clonsy) (object_length 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_msg clocc "normexp_forever return nforever")
	 (debug_msg clocc "normexp_forever return nforever")
	 (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))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_exit 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))
    (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_msg nexit "normexp_exit nexit")
       (debug_msg nbodbindings "normexp_exit nbodbindings")
       (return clocc nbodbindings)
       ))))
(install_method class_source_exit normal_exp normexp_exit)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize the compile_warning
(defun normexp_compilewarning  (recv env ncx psloc)
  (assert_msg "check compilewarn recv" (is_a recv class_source_compilewarning))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_compile_warning recv")
  (let ((sloc   (unsafe_get_field :loca_location recv)) 
	(swmsg (unsafe_get_field :scwarn_msg recv))
	(swexp (unsafe_get_field :scwarn_expr recv))
	)
    (warning_strv sloc "COMPILE_WARNING:" swmsg)
    (multicall 
     (nexp nbind)
     (normal_exp swexp env ncx sloc)
     (debug_msg nexp "normexp_compile_warning nesult nexp")
     (debug_msg nbind "normexp_compile_warning result nbind")
     (return nexp nbind)
     )))

(Install_method class_source_compilewarning normal_exp normexp_compilewarning)
(install_method class_source_compilewarning get_ctype 
		(lambda (recv env) (get_ctype (unsafe_get_field :scwarn_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))
  (assert_msg "check env" (is_a env class_environment))
  (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_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
(defun normexp_defun (recv  env ncx psloc)
  (assert_msg "check defun recv" (is_a recv class_source_defun))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_defun recv")
  (let ( (sloc (unsafe_get_field :loca_location recv))
	 (snam (unsafe_get_field :sdef_name recv))
	 (sformals (unsafe_get_field :sformal_args recv))
	 (sbody (unsafe_get_field :sfun_body recv))
	 (sfubind (find_env env snam))
	 (newenv (fresh_env env))
	 (oldproc (unsafe_get_field :nctx_curproc ncx))
	 (oldsymbcache (unsafe_get_field :nctx_symbcachemap ncx))
	 (closblis (make_list discr_list))
	 (nproc (instance class_nrep_defunroutproc
;;; dont forget to put the nil fields at end
			  :nrep_loc sloc
			  :nproc_body () ;filled later
			  :nrpro_name snam
			  :nrpro_argb sformals
			  :nrpro_closedb closblis
			  :nrpro_const (make_list discr_list)
			  :nrpro_thunklist (make_list discr_list)
			  :nrpro_datarout () ; filled below
			  :nrpro_dataclos () ; 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  (normal_predef discr_closure ncx sloc "discr_closure")
			      :ndclo_proc nproc
			      :ndclo_closv () ;filled below
			      ))
	 )
    (unsafe_put_fields ncx 
		       :nctx_curproc nproc
		       :nctx_symbcachemap (make_mapobject discr_map_objects 40))
    (add_nctx_data ncx ndatarout)
    (add_nctx_data ncx ndataclos)
    (assert_msg "check sfubind" (is_a sfubind class_function_binding))
    (unsafe_put_fields nproc :nrpro_datarout ndatarout :nrpro_dataclos ndataclos)
    (multiple_every 
     sformals
     (lambda (fbi :long ix)
       (assert_msg "check fbi" (is_a fbi class_formal_binding))
       (put_env newenv fbi)))
    (unsafe_put_fields newenv :env_proc nproc)
    (debug_msg newenv "normexp_defun updated :env_proc of of newenv")
    ;; add nproc into ncx
    (list_append (unsafe_get_field :nctx_proclist ncx) nproc)
    (multicall
     (nbody nbindings)
     (normalize_tuple sbody newenv ncx sloc)
     (debug_msg nbody "normexp_defun nbody before replace_last_by_return")
     (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_msg npbody "normexp_defun npbody after replace_last_by_return")
       )
     (unsafe_put_fields ncx :nctx_curproc oldproc :nctx_symbcachemap oldsymbcache)
     (let ( (clovtup 
	     (list_to_multiple 
	      closblis
	      discr_multiple
	      (lambda (bnd)
		(assert_msg "normexp_defun check bnd" (is_a bnd class_any_binding))
		(let ( (sy (unsafe_get_field :binder bnd)) 
		       ;; since sy is a symbol, its normalized form does not add any binding
		       ;; we normalize it in the *old* environment, not the new one
		       (nsy (normal_exp sy env ncx sloc))
		       )
		  nsy
		  )))) )
       (unsafe_put_fields ndataclos :ndclo_closv clovtup)
       )
     (unsafe_put_fields sfubind 
			:fixbind_data ndataclos
			)
     (debug_msg nproc "normexp_defun return nproc")
     (return nproc ())
     )
    ))
(install_method class_source_defun normal_exp normexp_defun)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; 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)
  (assert_msg "check lambda recv" (is_a recv class_source_lambda))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check newenv" (is_a newenv class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normalize_lambda recv")
  (debug_msg env "normalize_lambda env")
  (debug_msg newenv "normalize_lambda newenv")
  (let ( (sloc (unsafe_get_field :loca_location recv))
	 (sargs (unsafe_get_field :slam_argbind recv))
	 (sbody (unsafe_get_field :slam_body recv))
	 (csym (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))
	 (nproc (instance class_nrep_lambdaroutproc
			  :nrep_loc sloc
			  :nproc_body () ;filled later
			  :nrpro_name csym
			  :nrpro_argb sargs
			  :nrpro_closedb closedblist
			  :nrpro_const (make_list discr_list)
			  :nrpro_datarout () ; filled below
			  :nrpro_dataclos () ; not filled
			  :nrpro_thunklist (make_list discr_list)
			  ))
	 (ndatarout (instance class_nrep_dataroutine
			      :ndata_name csym
			      :ndata_discrx (normal_predef discr_routine ncx sloc "discr_routine")
			      :ndrou_proc nproc
			      ))
	 )
    (add_nctx_data ncx ndatarout)
    ;; update the context for the new proc & a fresh symbol cache map
    (unsafe_put_fields ncx 
		       :nctx_curproc nproc
		       :nctx_symbcachemap (make_mapobject discr_map_objects 40))
    (unsafe_put_fields nproc :nrpro_datarout ndatarout)
    (multiple_every
     sargs
     (lambda (fbi :long ix)
       (assert_msg "check fbi" (is_a fbi class_formal_binding))
       (put_env newenv fbi)))
    (unsafe_put_fields newenv :env_proc nproc)
    (debug_msg newenv "normalize_lambda updated :env_proc of newenv")
    (shortbacktrace_dbg "normalize_lambda" 15)
    ;; add nproc into ncx
    (list_append (unsafe_get_field :nctx_proclist ncx) nproc)
    (multicall
     (nbody nbindings)
     (normalize_tuple sbody newenv ncx sloc)
     (multiple_every
      nbindings
      (lambda (nbi :long ix)
	(put_env newenv nbi)))
     (unsafe_put_fields 
      nproc
      :nproc_body (wrap_normal_letseq (replace_last_by_return nbody newenv sloc) nbindings sloc)
      )
     ;; restore the previous symbol cache map & the old proc and return the normalized lambda
     (unsafe_put_fields ncx 
			:nctx_symbcachemap savedcachemap
			:nctx_curproc oldproc
			)
     (let ( 
	   ;; we make an anonymous constant for the routine unless in toplevel
	   (:long insideflag (is_a oldproc class_nrep_routproc))
	   (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)
				(assert_msg "normalize_lambda check bnd" (is_a bnd class_any_binding))
				(let ( (sy (unsafe_get_field :binder bnd)) 
				       ;; since sy is a symbol, its normalized form does not add any binding
				       ;; we normalize it in the *old* environment, not the new one
				       (nsy (normal_exp sy env ncx sloc))
				       )
				  nsy))))
	   (constrout  (if insideflag krout ndatarout))
	   )
       (return nproc csym clocc constrout clovtup sloc oldproc ndatarout insideflag)
       ))))

;;;;
(defun normexp_lambda (recv env ncx psloc)
  (assert_msg "check lambda recv" (is_a recv class_source_lambda))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_lambda recv")
  (let (
	(newenv (fresh_env env))
	)
    (multicall 
     (nproc csym clocc constrout clovtup sloc oldproc ndatarout :long insideflag)
     (normalize_lambda recv env newenv ncx psloc)
     (debug_msg nproc "normexp_lambda after normalize_lambda nproc")
     (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)
       (if insideflag
	   (list_append (unsafe_get_field :nrpro_const oldproc) ndatarout))
       (debug_msg clocc "normexp_lambda return clocc")
       (debug_msg nbindlist "normexp_lambda return 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))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_multicall 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_msg scall "normexp_multicall scall")
    (multicall
     (ncall ncallbindings)
     (normal_exp scall env ncx sloc)
     (debug_msg ncall "normexp_multicall ncall")
     (debug_msg ncallbindings "normexp_multicall 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))
     (let ( (ncallsym (unsafe_get_field :nocc_symb ncall)) 
	    (nboxcall (make_box discr_box ())) ;box 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))
	  (if (== ncallsym (unsafe_get_field :binder cbnd))
	      (let ( (nrealcallex (unsafe_get_field :letbind_expr cbnd)) )
		(box_put nboxcall nrealcallex)
		())
	    (progn (list_append nincallbindings cbnd) cbnd))))
       (setq nrealcall (box_content nboxcall))
       (debug_msg nrealcall "normexp_multicall got nrealcall")
       (multiple_every
	sresbind
	(lambda (bnd :long ix)
	  (put_env newenv bnd)))
       (multicall
	(nbody nbodybindings)
	(normalize_tuple sbody newenv ncx sloc)
	(debug_msg nbody "normexp_multicall nbody")
	(debug_msg nbodybindings "normexp_multicall 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))
	       (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_msg clocc "normexp_multicall multiapply result clocc")
		 (debug_msg nincallbindings "normexp_multicall multiapply result nincallbindings")
		 (return clocc nincallbindings)
		 )
	       )
	     ( (is_a scall class_source_msend)
	       (debug_msg nrealcall "normexp_multicall multicall 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))
	       (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_msg nrecv "normexp_multicall nrecv from multicall")
		 (assert_msg "check nrecv" (is_object nrecv))
		 (unsafe_put_fields cbind :letbind_expr nres)
		 (list_append nincallbindings cbind)
		 (debug_msg clocc "normexp_multicall multisend result clocc")
		 (debug_msg nincallbindings "normexp_multicall multisend result nincallbindings")
		 (return clocc nincallbindings)
		 )
	       )
	     ( :else
	       (error_plain sloc "multi-called 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))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_tuple 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"))
	 )
    (debug_msg csymrec "normexp_tuple csymrec")
    (multicall
     (nargs nbindings)
     (normalize_tuple sargs env ncx sloc)
     (debug_msg nargs "normexp_tuple nargs")
     (debug_msg nbindings "normexp_tuple 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_msg ctupbind "normexp_tuple ctupbind")
	     (debug_msg clocc "normexp_tuple clocc")
	     (debug_msg nbdy "normexp_tuple nbdy")
	     (debug_msg ctuplocc "normexp_tuple return ctuplocc")
	     (debug_msg nbindings "normexp_tuple return final 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))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_list 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"))
	 (: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_msg curbind "normexp_list curbind")
		       (assert_msg "check curbind" (is_a curbind class_normal_constructor_binding))
		       (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_msg csymrec "normexp_list csymrec")
    (debug_msg consbindtup "normexp_list consbindtup")
    (debug_msg conslistbind "normexp_list conslistbind")
    (debug_msg tuprecloc "normexp_list tuprecloc")
    (assert_msg "check conslistbind" (is_a conslistbind class_normal_constructed_list_binding))
    (multicall
     (nargs nbindings)
     (normalize_tuple sargs env ncx sloc)
     (debug_msg nargs "normexp_list nargs")
     (debug_msg nbindings "normexp_list nbindings")
     (assert_msg "check nbindings" (is_list_or_null nbindings))
     (list_append2list resbindings nbindings)
     (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_msg curpairb "normexp_list curpairb")
		(assert_msg "check curpairb" (is_a curpairb class_normal_constructed_pair_binding))
		(assert_msg "check curpairb objnum" (==i (get_int curpairb) nix))
		(debug_msg curnarg "normexp_list curnarg")
		(debug_msg nextb "normexp_list nextb")
		(assert_msg "check nextb" (is_a nextb class_normal_constructor_binding))
		(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_msg curpairb "normexp_list updated 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_msg conslistbind "normexp_list updated conslistbind")
	       )
	     ;;
	     (if (null nbindings)
		 (setq nbindings clistbindlist)
	       (list_append nbindings clistbind)
	       )
	     (debug_msg nletrec "normexp_list final nletrec")
	     (debug_msg clistlocc "normexp_list final clistlocc")
	     (debug_msg nbindings "normexp_list final nbindings")
	     (compile_warning "normexp_list is probably still buggy!!")
	     (return clistlocc nbindings)
	     ))))
(install_method class_source_list normal_exp normexp_list)
;;;;;;;;;;;;;;;;

(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_msg recv "bad_prepare_constructor_binding recv")
  (debug_msg symb "bad_prepare_constructor_binding symb")
  (error_strv sloc "invalid constructor binding" (get_field :named_name symb))
  (error_strv sloc "reciever unprepared to constructor binding" 
	      (get_field :named_name (discrim recv)))
  (assert_msg "@$@badmeth_prepare_constructor_binding" ())
)
(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 reciever, 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_msg cexpr "badmeth_normal_letrec_constructive cexpr")
  (debug_msg symb "badmeth_normal_letrec_constructive symb")
  (debug_msg cbind "badmeth_normal_letrec_constructive cbind")
  (error_strv sloc "invalid letrec constructive symbol" (get_field :named_name symb))
  (error_strv sloc "reciever unprepared to normal_letrec_constructive" 
	      (get_field :named_name (discrim cexpr)))
  (assert_msg "@$@badmeth_normal_letrec_constructive" ())
)
(install_method discr_any_receiver normal_letrec_constructive badmeth_normal_letrec_constructive)

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

;;;;


(defun normletrec_lambda  (cexpr symb cbind env ncx psloc)
  (debug_msg cexpr "normletrec_lambda cexpr")
  (debug_msg symb "normletrec_lambda symb")
  (debug_msg cbind "normletrec_lambda cbind")
  (debug_msg env "normletrec_lambda env")
  (assert_msg "check cbind" (is_a cbind class_normal_constructed_lambda_binding))
  (let ( (newenv (fresh_env env))
	 )
    (debug_msg newenv "normletrec_lambda newenv")
    (assert_msg "check newenv" (is_a newenv class_environment))
    (multicall
     (nproc csym clocc constrout clovtup sloc oldproc ndatarout :long insideflag)
     (normalize_lambda cexpr newenv newenv ncx psloc)
     ;;was     (normalize_lambda cexpr env newenv ncx psloc)
     (debug_msg csym "normletrec_lambda after normalize_lambda csym")
     (debug_msg clocc "normletrec_lambda after normalize_lambda clocc")
     (debug_msg constrout "normletrec_lambda after normalize_lambda constrout")
     (debug_msg clovtup  "normletrec_lambda after normalize_lambda clovtup")
     (debug_msg oldproc  "normletrec_lambda after normalize_lambda oldproc")
     (debug_msg ndatarout  "normletrec_lambda after normalize_lambda ndatarout")
     (if insideflag
	 (list_append (unsafe_get_field :nrpro_const oldproc) ndatarout))
     (put_fields cbind 
		 :nlambdab_nclosed clovtup 
		 :nlambdab_constrout constrout
		 :nlambdab_datarout ndatarout)
     (debug_msg cbind "normletrec_lambda updated 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_msg recv "prepcons_tuple recv")
  (debug_msg symb "prepcons_tuple symb")
  (assert_msg "check recv" (is_a recv class_source_tuple))
  (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_msg constup "prepcons_tuple gives constup")
    (return constup)
))
(install_method class_source_tuple prepare_constructor_binding prepcons_tuple)
;;;;

(defun normletrec_tuple  (cexpr symb cbind env ncx sloc)
  (debug_msg cexpr "normletrec_tuple cexpr")
  (debug_msg symb "normletrec_tuple symb")
  (debug_msg cbind "normletrec_tuple cbind")
  (assert_msg "check cexpr" (is_a cexpr class_source_tuple))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check cbind" (is_a cbind class_normal_constructed_tuple_binding))
  (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_msg sargs "normletrec_tuple sargs")
    (debug_msg bcomp "normletrec_tuple bcomp")
    (debug_msg nletrec "normletrec_tuple nletrec")
    (debug_msg nrecbinds "normletrec_tuple nrecbinds")
    (assert_msg "check nletrec" (is_a nletrec class_nrep_letrec))
    (assert_msg "check nrecbinds" (is_list nrecbinds))
    (multicall
     (nargs nbinds)
     (normalize_tuple sargs env ncx loc)
     (debug_msg nargs "normletrec_tuple nargs")
     (debug_msg nbinds "normletrec_tuple nbinds")
     (assert_msg "check nargs & bcomp samelength" (==i (multiple_length bcomp) (multiple_length nargs)))
     (assert_msg "check nbinds" (is_list_or_null nbinds))
     (foreach_in_multiple 
      (nargs)
      (curnarg :long nix)
      (multiple_put_nth bcomp nix curnarg))
     (debug_msg bcomp "normletrec_tuple updated bcomp")
     (list_append2list nrecbinds nbinds)
     (debug_msg nrecbinds "normletrec_tuple updated 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_msg recv "prepcons_list recv")
  (debug_msg symb "prepcons_list symb")
  (assert_msg "check recv" (is_a recv class_source_list))
  (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_msg curarg "prepcons_list 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_msg reslist "prepcons_list gives 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_msg symb "nreclist_find_locsym symb")
  (assert_msg "check symb" (is_a symb class_symbol))
  (assert_msg "check nletrec" (is_a nletrec class_nrep_letrec))
  (let ( (nlocsyms (get_field :nletrec_locsyms nletrec)) 
	 )
    (foreach_in_multiple
     (nlocsyms)
     (curlocsym :long locsymix)
     (if (== (get_field :nocc_symb curlocsym) symb)
	 (progn
	   (debug_msg curlocsym "nreclist_find_locsym found curlocsym")
	   (return curlocsym))))
    (debug_msg () "nreclist_find_locsym not found")
    (return)
    ))


(defun normletrec_list (cexpr symb cbind env ncx sloc)
  (debug_msg cexpr "normletrec_list cexpr")
  (debug_msg symb "normletrec_list symb")
  (debug_msg cbind "normletrec_list cbind")
  (assert_msg "check cexpr" (is_a cexpr class_source_list))
  ;; here cbind is a tuple of constructor bindings -for all the pairs
  ;; & the list
  (assert_msg "check cbind is tuple" (is_multiple 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_msg conslibind "normletrec_list conslibind")
    (assert_msg "check conslibind"
		(is_a conslibind class_normal_constructed_list_binding))
    (debug_msg sargs "normletrec_list sargs")
    (debug_msg nletrec "normletrec_list nletrec")
    (debug_msg nrecbinds "normletrec_list nrecbinds")
    (assert_msg "check nletrec" (is_a nletrec class_nrep_letrec))
    (assert_msg "check nrecbinds" (is_list nrecbinds))
    (multicall
     (nargs nbinds)
     (normalize_tuple sargs env ncx loc)
     (debug_msg nargs "normletrec_list nargs")
     (debug_msg nbinds "normletrec_list nbinds")
     (assert_msg "check nbinds" (is_list_or_null nbinds))
     (assert_msg "check nargs's length vs cbind's length"
		 (==i (multiple_length nargs) (-i (multiple_length cbind) 1)))
     (foreach_in_multiple
      (nargs)
      (curnarg :long nix)
      (debug_msg curnarg "normletrec_list 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_msg curcbind "normletrec_list curcbind")
	(debug_msg nextcbind "normletrec_list nextcbind")
	(debug_msg nextpairsymb "normletrec_list nextpairsymb")
	(assert_msg "check curcbind" (is_a curcbind class_normal_constructed_pair_binding))
	(let ( (nextpairloc	(if nextpairsymb (nreclist_find_locsym nextpairsymb nletrec))) )
	  (debug_msg nextpairloc "normletrec_list got nextpairloc")
	  (put_fields curcbind
		      :npairb_head curnarg
		      :npairb_tail nextpairloc)
	  (debug_msg curcbind "normletrec_list updated curcbind")
	  (assert_msg "check curcbind" (is_a curcbind class_normal_constructed_pair_binding))
	  )))
     (debug_msg firstpairbind "normletrec_list firstpairbind")
     (debug_msg lastpairbind "normletrec_list lastpairbind")
     (debug_msg conslibind "normletrec_list conslibind again")
     (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_msg firstpairlocsy "normletrec_list firstpairlocsy")
	    (debug_msg lastpairlocsy "normletrec_list lastpairlocsy")
	    (put_fields conslibind
			:nlistb_first firstpairlocsy
			:nlistb_last lastpairlocsy)
	    (debug_msg conslibind "normletrec_list updated conslibind")
	    (void)
	    ))
     (debug_msg nbinds "normletrec_list appending nbinds")
     (list_append2list nrecbinds nbinds)
     (debug_msg nrecbinds "normletrec_list ended updated nrecbinds")
     )))
(install_method class_source_list normal_letrec_constructive normletrec_list)


;;;;;;;;;;;;;;;;
(defun prepcons_instance (recv symb ncx sloc)
  (debug_msg recv "prepcons_instance recv")
  (debug_msg symb "prepcons_instance symb")
  (assert_msg "check recv" (is_a recv class_source_instance))
  (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))
    (debug_msg consinst "prepcons_instance gives consinst")
    (return consinst)
    )
  )
(install_method class_source_instance prepare_constructor_binding prepcons_instance)

;;;;

(defun normletrec_instance  (cexpr symb cbind env ncx sloc)
  (debug_msg cexpr "normletrec_instance cexpr")
  (debug_msg symb "normletrec_instance symb")
  (debug_msg cbind "normletrec_instance 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_msg nletrec "normletrec_instance nletrec")
    (if (not (is_a cladata class_nrep))
	(progn
	  (error_strv sloc "invalid class in (INSTANCE ..)" (unsafe_get_field :named_name sclass))
	  (return ())))
    (let ( (nfields 
	    (multiple_map 
	     sfields 
	     (lambda (curflda :long curk)
	       (assert_msg "check curflda" (is_a curflda class_source_fieldassign))
	       (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_msg nexp "normletrec_instance nexp")
		  (assert_msg "check nbind" (is_list_or_null nbind))
		  (list_append2list bindlist  nbind)
		  (instance class_nrep_fieldassign
			    :nrep_loc curfloc
			    :nfla_field curfield
			    :nfla_val nexp)
		  )))))
	   )
      (debug_msg nfields "normletrec_instance nfields")
      (foreach_in_multiple
       (nfields)
       (curnfieldass :long fldix)
       (debug_msg curnfieldass "normletrec_instance curnfieldass")
       (let ( (curfield (get_field :nfla_field curnfieldass)) 
	      (curfval (get_field :nfla_val curnfieldass))
	      (:long curfoff (get_int curfield))
	      )
	 (assert_msg "check curfield " (is_a curfield class_field))
	 (multiple_put_nth bslots curfoff curfval)
       ))
      (list_append2list nrecbinds bindlist)
      (debug_msg nrecbinds "normletrec_instance ended updated 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))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_letrec 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_msg cursbind "normexp_letrec cursbind")
     (assert_msg "check cursbind" (is_a cursbind class_source_letrec_binding))
     (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_msg curexpr "normexp_letrec curexpr")
       (debug_msg cursymb "normexp_letrec cursymb")
       (assert_msg "check curexpr" (is_a curexpr class_source))
       (assert_msg "check cursymb" (is_a cursymb class_symbol))
       (mapobject_put symbexprmap cursymb curexpr)
       (let ( (curconsbind (prepare_constructor_binding curexpr cursymb ncx locb))
	      )
	 (debug_msg curconsbind "normexp_letrec curconsbind")
	 (cond ( (is_a curconsbind class_normal_constructor_binding)
		 (debug_msg curconsbind "normexp_letrec curconsbind plain consbind")
		 (list_append consbindlist curconsbind)
		 (mapobject_put symbindmap cursymb curconsbind)
		 )
	       ( (is_multiple curconsbind)
		 (debug_msg curconsbind "normexp_letrec curconsbind multiple")
		 (foreach_in_multiple 
		  (curconsbind)
		  (subconsbind :long subix)
		  (assert_msg "normexp_letrec check subconsbind" 
			      (is_a subconsbind class_normal_constructor_binding))
		  (list_append consbindlist subconsbind))
		 (mapobject_put symbindmap cursymb curconsbind)
		 )
	       ( (is_list curconsbind)
		 (debug_msg curconsbind "normexp_letrec curconsbind list")
		 (foreach_in_list
		  (curconsbind)
		  (subconspair subconsbind)
		  (assert_msg "normexp_letrec check subconsbind" 
			      (is_a subconsbind class_normal_constructor_binding))
		  (list_append consbindlist subconsbind))
		 (mapobject_put symbindmap cursymb (list_to_multiple curconsbind discr_multiple))
		 )
	       (:else
		(assert_msg "normexp_letrec bad curconsbind" ())
		))
	 )
       )
     )
    (debug_msg consbindlist "normexp_letrec 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_msg nletrec "normexp_letrec unfilled nletrec")
      ;;
      ;; second loop to make an environment where each constructive
      ;; binding is set, and to create the local symbol occurrences
      (foreach_in_list
       (consbindlist)
       (curpair curcbind)
       (debug_msg curcbind "normexp_letrec curcbind")
       (assert_msg "check curcbind" (is_a curcbind class_normal_constructor_binding))
       (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_msg clabind "normexp_letrec clabind")
	       (debug_msg clasym "normexp_letrec 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))
	       (let ( ;; we normalize the class symbol in the parent environment, not the new one! 
		     (cladata (normal_exp clasym env ncx sloc)) 
		     )
		 (debug_msg cladata "normexp_letrec cladata")
		 (assert_msg "check cladata" (is_a cladata class_nrep))
		 (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_msg cursbind "normexp_letrec thirdloop cursbind")
       (assert_msg "check cursbind" (is_a cursbind class_source_letrec_binding))
       (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_msg curexpr "normexp_letrec thirdloop curexpr")
	 (debug_msg cursymb "normexp_letrec thirdloop cursymb")
	 (debug_msg curbind "normexp_letrec thirdloop curbind")
	 (debug_msg cursexpr "normexp_letrec thirdloop cursexpr")
	 (assert_msg "check curxpr same cursexpr" (== curexpr cursexpr))
	 (normal_letrec_constructive curexpr cursymb curbind newenv ncx sloc)
	 (debug_msg curexpr "normexp_letrec thirdloop done curexpr")
	 )
       )
      (debug_msg recfillbindings "normexp_letrec recfillbindings before normalizing the body")
;;;
;;; normalize the body
      (debug_msg sbody "normexp_letrec normalizing sbody")
      (multicall
       (nbody nbodbindings)
       (normalize_tuple sbody newenv ncx sloc)
       (debug_msg nbody "normexp_letrec nbody")
       (debug_msg nbodbindings "normexp_letrec nbodbindings")
       (assert_msg "normexp_letrec check nbodbindings" (is_list_or_null nbodbindings))
       (put_fields nletrec 
		   :nlet_body nbody
		   :nletrec_body_bindings nbodbindings)
       (debug_msg nletrec "normexp_letrec updated nletrec")
       (assert_msg "normexp_letrec check bindlist" (is_list_or_null bindlist))
;;; remove every locally bound symbol from the symbol cache map
       (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx)) )
	 (foreach_in_list
	  (bindlist)
	  (curpair bnd)
	  (debug_msg bnd "normexp_letrec removing from sycmap bnd")
	  (assert_msg "normexp_letrec check bnd" (is_a bnd class_normal_let_binding))
	  (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_msg clocc "normexp_letrec result clocc")
	 (debug_msg resbinds "normexp_letrec result 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 msg)
  (assert_msg "check pred" (is_object pred))
  (assert_msg "check nctxt"  (is_a ncx class_normalization_context))
  (let ( (predefmap (unsafe_get_field :nctx_predefmap ncx)) 
	 (brk (mapobject_get predefmap pred)) )
    (if (or (is_integerbox brk) (is_a brk class_symbol))
	(instance class_nrep_predef
		  :nrep_loc sloc
		  :nrpredef brk)
      (if (is_string msg) 
	  (progn
	    (debug_msg predefmap "normalpredef predefmap")
	    (debug_msg pred "normalpredef pred")
	    (error_strv sloc "not a predef:" msg)
	    ()
	    )))))


;; retrieve or create the normalized datasym for a symbol
(defun normal_symbol_data (sym ncx sloc)
  ;; sym should be strictly a symbol (not be in a subclass of class_symbol!)
  (debug_msg sym "normal_symbol_data start sym")
  (assert_msg "check symb" (== (discrim sym) class_symbol))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (let ( (valmap  (unsafe_get_field :nctx_valmap ncx))
	 (osydata (mapobject_get valmap sym)) )
    (if osydata
	(progn
	  (debug_msg osydata "normal_symbol_data found 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))
	     )
	(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_msg sydata "normal_symbol_data return 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!)
  (assert_msg "check keywb" (== (discrim keyw) class_keyword))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (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))
	     )
	(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)
	(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)) 
  (debug_msg cla "create_data_slots cla")
  (let ( (tupslo 
	  (make_multiple discr_multiple  (multiple_length (unsafe_get_field :class_fields cla)))) 
	 )
    (debug_msg tupslo "create_data_slots 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))
  (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)
  (assert_msg "check quote recv" (is_a recv class_source_quote))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
					;(debug_msg ncx "normexp_quote ncx")
  (debug_msg recv "normexp_quote recv")
  (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)
	     (normal_symbol_data quoted ncx psloc))
	   ( (is_integerbox quoted)
	     (let (
		   (nintdata (instance class_nrep_databoxedinteger
				       :ndata_discrx (normal_predef discr_constant_integer ncx sloc "discr_constant_integer") 
				       :nboxint_num quoted))
		   )
	       (add_nctx_data ncx nintdata)
	       nintdata
	       ))
	   ( (is_string quoted)
	     (let ( (nstrdata 
		     (instance class_nrep_datastring
			       :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
			       :nstr_string quoted))
		    )
	       (add_nctx_data ncx nstrdata)
	       nstrdata))
	   (:else
	    ;; this should not happen, because it is checked at
	    ;; macroexpansion time.
	    (assert_msg "unexpected quoted stuff" ()))

	   ))
	 )
    (debug_msg ndata "normexp_quote ndata")
    (if (is_a curproc class_nrep_routproc)
	(let ( 
	      (nconst (instance class_nrep_constant
				:nrep_loc sloc
				:nconst_sval quoted
				:nconst_data ndata
				:nconst_proc curproc
				)) )
	  (list_append (unsafe_get_field :nrpro_const curproc) ndata)
	  (debug_msg nconst "normexp_quote in routine nconst")
	  (return nconst))
      (progn
	(debug_msg ndata "normexp_quote in init ndata")
	(return ndata)
	))))
(install_method class_source_quote normal_exp normexp_quote)

;;;;;; normalize a COMMENT
(defun normexp_comment (recv env ncx psloc)
  (assert_msg "check comment recv" (is_a recv class_source_comment))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_comment start recv")
  (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)))
    (list_append bindlist cbind)
    (debug_msg ncomm "normexp_comment end ncomm")
    (debug_msg clocc "normexp_comment return clocc")
    (debug_msg bindlist "normexp_comment return bindlist")
    (return clocc bindlist)
    ))
(install_method class_source_comment normal_exp normexp_comment)

;;;;;; normalize a keyword
(defun normexp_keyword (recv env ncx psloc)
  (assert_msg "check keyword recv" (is_a recv class_keyword))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  ;;(debug_msg ncx "normexp_keyword ncx")
  (debug_msg recv "normexp_keyword recv")
  (let ( (kdata (normal_keyword_data recv ncx psloc)) 
	 (curproc (unsafe_get_field :nctx_curproc ncx)) 
	 )
    (assert_msg "check curproc" (is_a curproc class_nrep_anyproc))
    (if (is_a curproc class_nrep_routproc)
	(let (
	      (constlist (unsafe_get_field :nrpro_const curproc))
	      (nconst (instance class_nrep_constant
				:nrep_loc psloc
				:nconst_sval recv
				:nconst_data kdata
				:nconst_proc curproc))
	      )
	  (debug_msg curproc "normexp_keyword routine curproc")
	  (list_append constlist kdata)
	  (debug_msg nconst "normexp_keyword result nconst")
	  (return nconst)
	  )
      (progn
	(debug_msg kdata "normexp_keyword routineinit result 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))
  (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))
    (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))
     (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_msg expcomp "bad component in C code expansion expcomp")
		     (error_plain sloc "unexpected component in C code expansion"))))
	    )
       (multiple_put_nth nexptuple ix compdata)
       )))
  )

;;;;;; normalize a DEFPRIMITIVE
(defun normexp_defprimitive (recv env ncx psloc)
  (assert_msg "check defprimitive recv" (is_a recv class_source_defprimitive))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (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)
	(unsafe_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)
  (assert_msg "check defciterator recv" (is_a recv class_source_defciterator))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (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))
	(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))
    (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))
    (unsafe_put_fields citbind
		       :fixbind_data insdata 
		       )
;;;;;;;
    ;; return the data
    (debug_msg insdata "normexp_defciterator return insdata")
    (return insdata)
    ))
(install_method class_source_defciterator normal_exp normexp_defciterator)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a citeration
(defun normexp_citeration (recv env ncx psloc)
  (debug_msg recv "normexp_citeration recv")
  (assert_msg "check citeration recv" (is_a recv class_source_citeration))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (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))
    ;; normalize the iterator input arguments
    (multicall
     (nargs nbindings)
     (normalize_tuple sargs env ncx sloc)
     (if (null nbindings) (setq nbindings (make_list discr_list)))
     (debug_msg nargs "normexp_citeration nargs")
     (debug_msg nbindings "normexp_citeration nbindings")
     (let ( (starformals (unsafe_get_field :citer_start_formals soper)) )
       (debug_msg starformals "normexp_citeration starformals")
       (if (!=i (multiple_length starformals) (multiple_length nargs))
	   (progn
	     (error_strv sloc "start formals and actuals length mismatch in citerator" (unsafe_get_field :named_name soper))
	     (return)))
       (multiple_every_both 
	nargs starformals
	(lambda (curnarg curforb :long ix)
	  (debug_msg curnarg "normexp_citeration curnarg")
	  (debug_msg curforb "normexp_citeration curforb")
	  (assert_msg "check curforb" (is_a curforb class_formal_binding))
	  (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_strv sloc "start formal and actual type mismatch in citerator" (unsafe_get_field :named_name soper))
		(inform_strv sloc "mismatched citerator start formal argument" (unsafe_get_field :named_name formarg))))
	    ))
	)
       (debug_msg nbndtup "normexp_citeration nbndtup")
       ;; bind the local vars
       (debug_msg svbind "normexp_citeration 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_msg citbform "normexp_citeration citbform")
	 (if (!=i nbcitbform (multiple_length svbind))
	     (progn
	       (error_strv sloc "body formals and actuals length mismatch in citerator" (unsafe_get_field :named_name soper))
	       (return)))
	 (multiple_every_both 
	  svbind citbform
	  (lambda (curvbind curbform :long ix)
	    (debug_msg curvbind "normexp_citeration curvbind")
	    (debug_msg curbform "normexp_citeration curbform")
	    (assert_msg "check curvbind" (is_a curvbind class_formal_binding))
	    (assert_msg "check curbform" (is_a curbform class_formal_binding))
	    (let ( (curvsym (unsafe_get_field :binder curvbind))
		   (curctyp (unsafe_get_field :fbind_type curvbind))
		   (curvfor (unsafe_get_field :binder curbform))
		   )
	      (if (== curctyp (unsafe_get_field :fbind_type curbform))
		  (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_msg nlvbind "normexp_citeration 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)
		    (list_append uncachelist curvsym)
		    )
		(progn
		  (error_strv sloc "local formal and actual type mismatch in citerator" (unsafe_get_field :named_name soper))
		  (inform_strv sloc "mismatched citerator local variable" 
			       (unsafe_get_field :named_name (unsafe_get_field :binder curvbind)))
		  ))
	      )
	    (put_env bodyenv curvbind)
	    ))
	 (debug_msg nlocbindtup "normexp_citeration nlocbindtup")
	 (debug_msg nsymocctup "normexp_citeration nsymocctup")
	 (multicall
	  (nbody nbodbindings)
	  (normalize_tuple sbody bodyenv ncx sloc)
	  (debug_msg nbody "normexp_citeration nbody")
	  (debug_msg nbodbindings "normexp_citeration nbodbindings")
	  (let ( (citstate (unsafe_get_field :citer_state soper))
		 (citstsym (clone_symbol citstate))
		 (citstbind (instance class_normal_let_binding
				      :letbind_loc sloc
				      :binder citstsym
				      :letbind_type ctype_void
				      :letbind_expr ()))
		 (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_msg xtup "normexp_citeration expanding xtup")
		    (multiple_map 
		     xtup 
		     (lambda (curelem :long ix)
		       (if (is_a curelem class_symbol)
			   (let ( (exelem (mapobject_get citlocmap curelem)) )
			     (if (null exelem)
				 (debug_msg curelem "normexp_citeration bad curelem"))
			     (assert_msg "check exelem in citeration" exelem)
			     exelem)
			 curelem)
		       ))
		    ))
		 )
	    (mapobject_put citlocmap citstate citstocc)
	    (debug_msg starformals "normexp_citeration starformals again")
	    (debug_msg nsymocctup "normexp_citeration nsymocctup again")
	    (multiple_every_both 
	     starformals nargs
	     (lambda (curvloc curnarg :long ix)
	       (debug_msg curvloc "normexp_citeration curvloc")
	       (debug_msg curnarg "normexp_citeration curnarg")
	       (mapobject_put citlocmap (unsafe_get_field :binder curvloc) curnarg)
	       ))
	    (debug_msg citlocmap "normexp_citeration citlocmap middle")
	    (debug_msg citbform "normexp_citeration citbform again")
	    (multiple_every
	     citbform
	     (lambda (curformb :long ix)
	       (assert_msg "check curform" (is_a curformb class_formal_binding))
	       (mapobject_put citlocmap
			      (unsafe_get_field :binder curformb)
			      (multiple_nth  nsymocctup ix))
	       
	       ))
	    (debug_msg citlocmap "normexp_citeration citlocmap done")
	    (let ( (chkbefore (citexpander citexpbefore))
		   (chkafter (citexpander citexpafter))
		   )
	      (debug_msg chkbefore "normexp_citeration chkbefore")
	      (debug_msg chkafter "normexp_citeration 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_msg nciter "normexp_citeration nciter")
		(debug_msg clocc "normexp_citeration result clocc")
		(debug_msg nbindings "normexp_citeration result 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))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_defcmatcher 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_msg cm "normexp_defcmatcher cmatcher")
		     (assert_msg "check cmatcher" (is_a cm class_cmatcher))
		     cm))
	 (cmbind (let ( (b (find_env env sname)) )
		   (debug_msg b "normexp_defcmatcher cmbind")
		   (assert_msg "check cmbind" (is_a b class_cmatcher_binding))
		   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))
    (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
    (unsafe_put_fields cmbind :fixbind_data insdata)
    ;; return the data
    (debug_msg insdata "normexp_defcmatcher return insdata")
    (return insdata)
    )
  )
(install_method class_source_defcmatcher normal_exp normexp_defcmatcher)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a DEFUNMATCHER
(defun normexp_defunmatcher (recv env ncx psloc)
  (debug_msg recv "normexp_defunmatcher start recv")
  (assert_msg "normexp_defunmatcher check recv" (is_a recv class_source_defunmatcher))
  (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_msg b "normexp_defunmatcher fmbind")
		   (assert_msg "check fmbind" (is_a b class_funmatcher_binding))
		   b))
	 (funmatcher (get_field :fmbind_funmatcher fmbind))
	 )
    (debug_msg funmatcher "normexp_defunmatcher made funmatcher")
    (assert_msg "check smatched" (is_a smatched class_formal_binding))
    (assert_msg "check sins" (is_multiple sins))
    (assert_msg "check souts" (is_multiple souts))
    (assert_msg "check mbifma" (is_a mbifma class_formal_binding))
    (multicall
     (nmatchf nmabinds)
     (normal_exp smatchf env ncx sloc)
     (debug_msg nmatchf "normexp_defunmatcher nmatchf")
     (list_append2list resbinds nmabinds)
     (multicall
      (napplf napbinds)
      (normal_exp sapplyf env ncx sloc)
      (debug_msg napplf "normexp_defunmatcher napplf")
      (list_append2list resbinds napbinds)
      (multicall
       (ndata ndabinds)
       (normal_exp sdata env ncx sloc)
       (debug_msg ndata "normexp_defunmatcher ndata")
       (debug_msg resbinds "normexp_defunmatcher 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
	 (unsafe_put_fields fmbind :fixbind_data insdata)
;;; make a funmatcher binding
	 (debug_msg fmbind "normexp_defunmatcher final fmbind")
	 (compile_warning "$@$incomplete normexp_defunmatcher" ())
;;; return insdata and resbinds
	 (debug_msg insdata "normexp_defunmatcher return insdata")
	 (debug_msg resbinds "normexp_defunmatcher return resbinds")
	 (return insdata resbinds)
	 )
       )))
    ))
(install_method class_source_defunmatcher normal_exp normexp_defunmatcher)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a DEFCLASS
(defun normexp_defclass (recv env ncx psloc)
  (assert_msg "check defclass recv" (is_a recv class_source_defclass))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (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))
    (let ( (claobj (unsafe_get_field :cbind_class sclabind)) 
	   (namsymdata (normal_symbol_data sname ncx sloc))
	   (namstrdata
	    (instance class_nrep_datastring
		      :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
		      :nstr_string (unsafe_get_field :named_name sname)
		      ))
	   (claslots (make_multiple discr_multiple (obj_len claobj)))
	   (cladata 
	    (instance class_nrep_datainstance
		      :nrep_loc sloc
		      :ndata_name sname
		      :ndata_discrx (normal_predef class_class ncx sloc "class_class")
		      :ninst_hash  (make_integerbox discr_integer (obj_hash claobj))
		      :ninst_predef spredef
		      :ninst_slots claslots
		      :ninst_objnum 'OBMAG_OBJECT
		      )) 
	   (ancseq (unsafe_get_field :class_ancestors claobj))
	   (:long nbanc (multiple_length ancseq))
	   (anctup (make_multiple discr_multiple nbanc))
	   (ancdata (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 "check claobj" (is_a claobj class_class))
      (add_nctx_data ncx cladata)
      (add_nctx_data ncx namstrdata)
      (add_nctx_data ncx ancdata)
      (add_nctx_data ncx flddata)
      (fill_data_slot cladata named_name namstrdata)
      (fill_data_slot cladata class_ancestors ancdata)
      (fill_data_slot cladata class_fields flddata)
      (assert_msg "check sclabind" (is_a sclabind class_class_binding))
      (unsafe_put_fields sclabind 
			 :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))
		 (let ( (ownfldsym (unsafe_get_field :binder ownfldbind))
			(ownfld (unsafe_get_field :flbind_field ownfldbind))
			)
		   (assert_msg "check ownfldsym" (is_a ownfldsym class_symbol))
		   (assert_msg "check ownfld" (is_a ownfld class_field))
		   (let ( (ownfldsymdata (normal_symbol_data ownfldsym ncx sloc)) 
			  (ownfldslots (make_multiple discr_multiple (obj_len ownfld)))
			  (ownflstrdata 
			   (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
		     (unsafe_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
      cladata
      )))
(install_method class_source_defclass normal_exp normexp_defclass)




;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a DEFINSTANCE
(defun normexp_definstance (recv env ncx psloc)
  (assert_msg "check definstance recv" (is_a recv class_source_definstance))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_definstance recv")
  (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))
	 (nbindbox (make_box discr_box 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_msg bindins "normexp_definstance bindins")
    (assert_msg "check bindins" (is_a  bindins class_instance_binding))
    (if (not (is_a icladata class_nrep))
	(progn
	  (error_strv sloc "invalid class in definstance" (unsafe_get_field :named_name sname))
	  (return ())))
    (cond
     ( (null spredef) () )
     ( (is_integerbox spredef) () )
     ( (is_a spredef class_symbol) () )
     (:else
      (error_strv sloc "bad predef in DEFINSTANCE"  (unsafe_get_field :named_name sname))
      (return ())))
    (assert_msg "check sinstclass" (is_a sinstclass class_class))
    (assert_msg "check sinstclasym" (is_a sinstclasym class_symbol))
    (let (
	  (slotup (make_multiple discr_multiple
				 (multiple_length (unsafe_get_field :class_fields sinstclass))))
	  (insdata (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)
      (unsafe_put_fields bindins 
			 :fixbind_data insdata
			 )
      ;; scan the fields initialization
      (multiple_every
       sinstfields
       (lambda (flda :long ix)
	 (debug_msg flda "normexp_definstance flda")
	 (assert_msg "check flda" (is_a flda class_source_fieldassign))
	 (let ( (curfld (unsafe_get_field :sfla_field flda))
		(curexp (unsafe_get_field :sfla_expr flda))
		(:long curoff (obj_num curfld))
		)
	   (assert_msg "check curfld" (is_a curfld class_field))
	   (assert_msg "good curfld"
		       (== (multiple_nth (unsafe_get_field :class_fields sinstclass) curoff) 
			   curfld))  
	   (debug_msg curexp "normexp_definstance field curexp")
	   (multicall
	    (ncur nbindcur)
	    (normal_exp curexp env ncx sloc)
	    (debug_msg ncur "normexp_definstance field ncur")
	    (multiple_put_nth slotup curoff ncur)
	    (if (is_list nbindcur)
		(let ( (thebindlist (box_content nbindbox)))
		  (setq thebindlist (list_append2list thebindlist nbindcur))
		  (box_put nbindbox thebindlist)))))))
;;; put the binding into the data
      (let ( (thebindlist (box_content nbindbox)) 
	     (nbindtup (list_to_multiple thebindlist discr_multiple))
	     )
	(if (>i (multiple_length nbindtup) 0) 
	    (unsafe_put_fields insdata :ndata_locbind nbindtup))
	;; return the data
	(debug_msg insdata "normexp_definstance return insdata")
	insdata
	))))
(install_method class_source_definstance normal_exp normexp_definstance)


;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a DEFSELECTOR
(defun normexp_defselector (recv env ncx psloc)
  (assert_msg "check defselector recv" (is_a recv class_source_defselector))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp defselector recv")
  (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))
	(nbindbox (make_box discr_box 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))
    (if (not (is_a icladata class_nrep))
	(progn
	  (error_strv sloc "invalid class in defselector" (unsafe_get_field :named_name sname))
	  (return ())))
    (if spredef
	(if (not (or (is_integerbox spredef) (is_a spredef class_symbol)))
	    (progn (error_strv sloc "bad predef in defselector"  (unsafe_get_field :named_name sname))
		   (return ()))))
    (assert_msg "check sinstclass" (is_a sinstclass class_class))
    (assert_msg "check sinstclasym" (is_a sinstclasym class_symbol))
    (assert_msg "check sname" (is_a sname class_symbol))
    (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)
      (unsafe_put_fields bindsel
			 :fixbind_data insdata
			 )
      ;; scan the fields initialization
      (multiple_every
       sinstfields
       (lambda (flda :long ix)
	 (assert_msg "check flda" (is_a flda class_source_fieldassign))
	 (let ( (curfld (unsafe_get_field :sfla_field flda))
		(curexp (unsafe_get_field :sfla_expr flda))
		(:long curoff (obj_num curfld))
		)
	   (assert_msg "check curfld" (is_a curfld class_field))
	   (assert_msg "good curfld"
		       (== (multiple_nth (unsafe_get_field :class_fields sinstclass) curoff) 
			   curfld))  
	   (multicall
	    (ncur nbindcur)
	    (normal_exp curexp env ncx sloc)
	    (multiple_put_nth slotup curoff ncur)
	    (if (is_list nbindcur)
		(let ( (thebindlist (box_content nbindbox)))
		  (setq thebindlist (list_append2list thebindlist nbindcur))
		  (box_put nbindbox thebindlist)))))))
;;; put the binding into the data
      (let ( (thebindlist (box_content nbindbox)) 
	     (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)
	    (unsafe_put_fields bindsel
			       :fixbind_data insdata
			       ))
	;; return the data
	(debug_msg insdata "normexp_defselector return insdata")
	insdata
	))))
(install_method class_source_defselector normal_exp normexp_defselector)


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

;;;;;; (export_values v ...) 
;; is equivalent to
;;;;;; let  _valuexporter = the_system_data.sysdata_value_exporter 
;;;;;; then _quotev = 'v
;;;;;; then _norm_v = v
;;;;;; then _curenv = (current_module_environment)
;;;;;; then :void _exported_v = _valueexporter _quotev _norm_v 
;;;;;; in _exported_v
;; where _valuexporter _quotev _norm_v _exported_v are fresh variables 
;; and the_system_data is accessed using predef-s

;;; internal function giving a normalized cloned symbol for the value exporter
;;; return only one result, and update the bindslist
(defun normal_value_exporter (env ncx psloc bindslist)
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check bindslist" (is_list bindslist))
  (assert_msg "check ncx" (is_a ncx class_normalization_context))
  (let ( (csymvalexp (clone_symbol '_valuexporter_))
	 (nsysdat (instance class_nrep_predef
			    :nrep_loc psloc
			    :nrpredef 'INITIAL_SYSTEM_DATA))
	 (cbind (instance class_normal_let_binding
			  :letbind_loc psloc
			  :binder csymvalexp
			  :letbind_type ctype_value
			  :letbind_expr (instance class_nrep_unsafe_get_field
						  :nrep_loc psloc
						  :nuget_obj nsysdat
						  :nuget_field sysdata_value_exporter)))
	 (locsym (instance class_nrep_locsymocc
			   :nrep_loc psloc
			   :nocc_ctyp ctype_value
			   :nocc_symb csymvalexp
			   :nocc_bind cbind))
	 )
    (list_append bindslist cbind)
    (return locsym)
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; internal function for value export
;;
;;; sym is the exported symbol
;;
;;; nexp is the normalized expression of its value
;;
;;; nvalueexp is the normalized expression of the value exporter given
;;; by normal_value_exporter above
(defun normal_exported_value (sym nexp nvaluexp env ncx psloc bindslist)
  (debug_msg sym "normal_exported_value start sym")
  (debug_msg nexp "normal_exported_value start nexp")
  (debug_msg nvaluexp "normal_exported_value start nvaluexp")
  (assert_msg "check sym" (is_a sym class_symbol))
  (assert_msg "check nexp" (is_a nexp class_nrep))
  (assert_msg "check nvaluexp" (is_a nvaluexp class_nrep))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check ncx" (is_a ncx class_normalization_context))
  (assert_msg "check bindslist" (is_list 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_container
			       :loca_location psloc
			       :cmec_comment (strbuf2string discr_string csbuf)))
	 )
    (debug_msg scurenvbox "normal_exported_value scurenvbox")
    (multicall 
     (ncurenvbox curenvbinds)
     (normal_exp scurenvbox env ncx psloc)
     (debug_msg ncurenvbox "normal_exported_value ncurenvbox")
     (debug_msg curenvbinds "normal_exported_value curenvbinds")
     ;;; if we are not at topevel 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_apply
						    :nrep_loc psloc
						    :nexpr_ctyp ctype_value
						    :napp_fun nvaluexp
						    :nexpr_args argtup
						    )))
	   (syocc (instance class_nrep_locsymocc
			    :nrep_loc psloc
			    :nocc_ctyp ctype_void 
			    :nocc_symb csymexpo
			    :nocc_bind cbind) )
	   )
       (debug_msg cbind "normal_exported_value cbind")
       (debug_msg syocc "normal_exported_value return 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.
  (assert_msg "check exportval recv" (is_a recv class_source_export_values))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_export_values recv")
  (let ( 
	(sloc (unsafe_get_field :loca_location recv))
	(sxnames (unsafe_get_field :sexport_names recv))
	(bindslist (make_list discr_list))
	(nvaluexporter (normal_value_exporter env ncx sloc bindslist))
	(nilnrep (instance class_nrep_nil
			   :nrep_loc sloc))
	)
    (debug_msg nvaluexporter "normexp_export_values nvaluexporter")
    (multiple_every
     sxnames
     (lambda (xnam :long ix)
       (assert_msg "check xnam" (is_a xnam class_symbol))
       (debug_msg xnam "normexp_export_values xnam")
       (multicall
	(nsym nsymbinds)
	(normal_exp xnam env ncx sloc)
	(debug_msg nsym "normexp_export_values nsym")
	(debug_msg nsymbinds "normexp_export_values nsymbinds")
	(list_append2list bindslist nsymbinds)
	(debug_msg xnam "normexp_export_values xnam again")
	(debug_msg bindslist "normexp_export_values before normal_exported_value bindslist")
	(let ( (nexpv (normal_exported_value xnam nsym nvaluexporter env ncx sloc bindslist))
	       )
	  (debug_msg nexpv "normexp_export_values normal_exported_value gave nexpv")
	  ))))
    (debug_msg nilnrep "normexp_export_values final nilnrep")
    (debug_msg bindslist "normexp_export_values final 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..
  (assert_msg "check exportsyn recv" (is_a recv class_source_export_synonym))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_export_synonym recv")
  (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))
	(nvaluexporter (normal_value_exporter env ncx sloc bindslist))
	(nilnrep (instance class_nrep_nil
			   :nrep_loc sloc))
	)
    (debug_msg nvaluexporter "normexp_export_synonym nvaluexporter")
    (debug_msg newname "normexp_export_synonym newname")
    (debug_msg oldname "normexp_export_synonym oldname")
    (assert_msg "check newname" (is_a newname class_symbol))
    (assert_msg "check oldname" (is_a oldname class_symbol))
    ;; 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_msg noldsym "normexp_export_synonym noldsym")
     (debug_msg noldsymbinds "normexp_export_synonym noldsymbinds")
     (list_append2list bindslist noldsymbinds)
     (let ( (nexpv (normal_exported_value newname noldsym nvaluexporter env ncx sloc bindslist))
	    )
       (debug_msg nexpv "normexp_export_synonym normal_exported_value gave nexpv")
       (debug_msg nilnrep "normexp_export_synonym final nilnrep")
       (debug_msg bindslist "normexp_export_synonym final 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)
  (assert_msg "check export_class recv" (is_a recv class_source_export_class))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp export_class recv")
  (let ( 
	(sloc (unsafe_get_field :loca_location recv))
	(sxnames (unsafe_get_field :sexport_names recv))
	(bindslist (make_list discr_list))
	(nvaluexporter (normal_value_exporter env ncx sloc bindslist))
	(nilnrep (instance class_nrep_nil
			   :nrep_loc sloc))
	(mocx (unsafe_get_field :nctx_modulcontext ncx))
	)
    (assert_msg "check mocx" (is_a mocx class_module_context))
    (multiple_every
     sxnames
     (lambda (xnam :long ix)
       (assert_msg "check xnam" (is_a xnam class_symbol))
       (let ( (xbind (find_env env xnam)) 
	      (xsymdata (normal_symbol_data xnam ncx sloc))
	      )
	 (debug_msg xbind "normexp_export_class xbind")
	 (assert_msg "check xsymdata" (is_a xsymdata class_nrep_datasymbol))
	 (if (is_not_a xbind class_class_binding)
	     (progn 
	       (error_strv sloc "EXPORT_CLASS with non-class-bound symbol"
			   (unsafe_get_field :named_name xnam))
	       (return)
	       ))
	 (let ( (xdata (unsafe_get_field :fixbind_data xbind)) 
		(xclass (unsafe_get_field :cbind_class xbind))
		)
	   (debug_msg xdata "normexp_export_class xdata")
	   (if (is_not_a xdata class_nrep_data)
	       (error_strv sloc "forward defined class symbol to EXPORT_CLASS"
			   (unsafe_get_field :named_name xnam)))
	   (let ( (nclav (normal_exported_value xnam xdata nvaluexporter env ncx sloc bindslist))
		  )
	     (debug_msg nclav "normexp_export_class nclav")
	     (assert_msg "check xclass" (is_a xclass class_class))
	     (let ( (xclfields (unsafe_get_field :class_fields xclass)) 
		    ;; temporarily, to be able to melt bootstrap, we
		    ;; have to check the object length of mocx
		    (expcladic
		     (if (>i (object_length mocx) (get_int mocx_expclassdict))
			 (unsafe_get_field :mocx_expclassdict mocx)))
		    (expfldic
		     (if (>i (object_length mocx) (get_int mocx_expfieldict))
			 (unsafe_get_field :mocx_expfieldict mocx)))
		    )
	       (mapstring_putstr expcladic (unsafe_get_field :named_name xclass) xclass)
	       (multiple_every
		xclfields
		(lambda (curfld :long ix)
		  (assert_msg "check curfld" (is_a curfld class_field))
		  (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))
			  (let ( (fldata (unsafe_get_field :fixbind_data fldbind))
				 (field (unsafe_get_field :flbind_field fldbind))
				 (nfld (normal_exported_value fldsym fldata nvaluexporter env ncx sloc bindslist))
				 )
			    (assert_msg "check field" (is_a field class_field))
			    (mapstring_putstr expfldic (unsafe_get_field :named_name field) field)
			    (debug_msg nfld "normexp_export_class nfld")
			    ))))))))))
       ))
    (debug_msg nilnrep "normexp_export_class final nilnrep")
    (debug_msg bindslist "normexp_export_class final bindslist")
    (return nilnrep bindslist)
    ))
(install_method class_source_export_class normal_exp normexp_export_class)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; internal function giving a normalized cloned symbol for the macro exporter
;;; return only one result, and update the bindslist
(defun normal_macro_exporter (env ncx psloc bindslist)
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check bindslist" (is_list bindslist))
  (assert_msg "check ncx" (is_a ncx class_normalization_context))
  (debug_msg psloc "normal_macro_exporter start psloc")
  (let ( (csymvalexp (clone_symbol '_macroxporter_))
	 (nsysdat (instance class_nrep_predef
			    :nrep_loc psloc
			    :nrpredef 'INITIAL_SYSTEM_DATA))
	 (cbind (instance class_normal_let_binding
			  :letbind_loc psloc
			  :binder csymvalexp
			  :letbind_type ctype_value
			  :letbind_expr (instance class_nrep_unsafe_get_field
						  :nrep_loc psloc
						  :nuget_obj nsysdat
						  :nuget_field sysdata_macro_exporter)))
	 (locsym (instance class_nrep_locsymocc
			   :nrep_loc psloc
			   :nocc_ctyp ctype_value
			   :nocc_symb csymvalexp
			   :nocc_bind cbind))
	 )
    (list_append bindslist cbind)
    (debug_msg locsym "normal_macro_exporter return locsym")
    (return locsym)
    ))

;;; internal function giving a normalized cloned symbol for the patmacro exporter
;;; return only one result, and update the bindslist
(defun normal_patmacro_exporter (env ncx psloc bindslist)
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check bindslist" (is_list bindslist))
  (assert_msg "check ncx" (is_a ncx class_normalization_context))
  (debug_msg psloc "normal_patmacro_exporter start psloc")
  (let ( (csymvalexp (clone_symbol '_patmacroxporter_))
	 (nsysdat (instance class_nrep_predef
			    :nrep_loc psloc
			    :nrpredef 'INITIAL_SYSTEM_DATA))
	 (cbind (instance class_normal_let_binding
			  :letbind_loc psloc
			  :binder csymvalexp
			  :letbind_type ctype_value
			  :letbind_expr (instance class_nrep_unsafe_get_field
						  :nrep_loc psloc
						  :nuget_obj nsysdat
						  :nuget_field sysdata_patmacro_exporter)))
	 (locsym (instance class_nrep_locsymocc
			   :nrep_loc psloc
			   :nocc_ctyp ctype_value
			   :nocc_symb csymvalexp
			   :nocc_bind cbind))
	 )
    (list_append bindslist cbind)
    (debug_msg locsym "normal_patmacro_exporter return locsym")
    (return locsym)
    ))

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


;; return the normalized application to do the macro expport
(defun normal_exported_macro (sym nexp nmacroxp env ncx psloc bindslist)
  (debug_msg sym "normal_exported_macro start sym")
  (debug_msg nexp "normal_exported_macro start nexp")
  (debug_msg nmacroxp "normal_exported_macro start nmacroxp")
  (assert_msg "check sym" (is_a sym class_symbol))
  (assert_msg "check nexp" (is_a nexp class_nrep))
  (assert_msg "check nmacroxp" (is_a nmacroxp class_nrep))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check ncx" (is_a ncx class_normalization_context))
  (assert_msg "check bindslist" (is_list 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_container
			       :loca_location psloc
			       :cmec_comment (strbuf2string discr_string csbuf)))
	 )
    (debug_msg scurenvbox "normal_exported_macro sgetcurenvbox")
    (multicall 
     (ncurenvbox curenvbinds)
     (normal_exp scurenvbox env ncx psloc)
     (debug_msg ncurenvbox "normal_exported_macro ncurenvbox")
     (debug_msg curenvbinds "normal_exported_macro 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_apply
						    :nrep_loc psloc
						    :nexpr_ctyp ctype_void
						    :napp_fun nmacroxp
						    :nexpr_args argtup
						    )))
	   (syocc (instance class_nrep_locsymocc
			    :nrep_loc psloc
			    :nocc_ctyp ctype_void 
			    :nocc_symb csymexpo
			    :nocc_bind cbind) )
	   )
       (debug_msg cbind "normal_exported_macro cbind")
       (debug_msg syocc "normal_exported_macro return syocc")
       (list_append bindslist cbind)
       syocc
       ;;
       ))))

;;;; normalize an export_macro
(defun normexp_export_macro (recv env ncx psloc)
  (assert_msg "check export_macro recv" (is_a recv class_source_export_macro))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp export_macro recv")
  (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))
	(nmacexp (normal_macro_exporter env ncx sloc bindslist))
	(nrepnil (instance class_nrep_nil :nrep_loc sloc))
	)
    (assert_msg "check mname" (is_a mname class_symbol))
    (multicall 
     (nexp nbinds)
     (normal_exp mvalexp env ncx sloc)
     (list_append2list bindslist nbinds)
     (let ( 
	   (nexpm (normal_exported_macro mname nexp nmacexp env ncx sloc bindslist))
	   )
       (debug_msg nexpm "normexp_export_macro nexpm")
       )
     (debug_msg nrepnil "normexp_export_macro final nrepnil")
     (debug_msg bindslist "normexp_export_macro final bindslist")
     (return nrepnil bindslist)
     )))
(install_method class_source_export_macro normal_exp normexp_export_macro)

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


;; return the normalized application to do the patmacro expport
;; sym is the symbol which is export_patmacro-ed
;; nexp is the nrep of the patmatchexporter
;; nmacroxp is the nrep of the macro expander
;; npattxp is the nrep of the pattern expander
(defun normal_exported_patmacro (sym nexp nmacroxp npattxp env ncx psloc bindslist)
  (debug_msg sym "normal_exported_patmacro start sym")
  (debug_msg nexp "normal_exported_patmacro start nexp")
  (debug_msg nmacroxp "normal_exported_patmacro start nmacroxp")
  (debug_msg npattxp "normal_exported_patmacro start npattxp")
  (assert_msg "check sym" (is_a sym class_symbol))
  (assert_msg "check nexp" (is_a nexp class_nrep))
  (assert_msg "check nmacroxp" (is_a nmacroxp class_nrep))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check ncx" (is_a ncx class_normalization_context))
  (assert_msg "check bindslist" (is_list 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_container
			       :loca_location psloc
			       :cmec_comment (strbuf2string discr_string csbuf)))
	 )
    (debug_msg scurenvbox "normal_exported_patmacro sgetcurenvbox")
    (multicall 
     (ncurenvbox curenvbinds)
     (normal_exp scurenvbox env ncx psloc)
     (debug_msg ncurenvbox "normal_exported_patmacro ncurenvbox")
     (debug_msg curenvbinds "normal_exported_patmacro 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_apply
						    :nrep_loc psloc
						    :nexpr_ctyp ctype_void
						    :napp_fun nexp
						    :nexpr_args argtup
						    )))
	   (syocc (instance class_nrep_locsymocc
			    :nrep_loc psloc
			    :nocc_ctyp ctype_void 
			    :nocc_symb csymexpo
			    :nocc_bind cbind) )
	   )
       (debug_msg cbind "normal_exported_patmacro cbind")
       (debug_msg syocc "normal_exported_patmacro return syocc")
       (list_append bindslist cbind)
       syocc
       ;;
       ))))
;;;;;;;;;;;;;;;;
;;;; normalize an export_patmacro
(defun normexp_export_patmacro (recv env ncx psloc)
  (assert_msg "check export_patmacro recv" (is_a recv class_source_export_patmacro))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp export_patmacro recv")
  (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))
	(npmaexp (normal_patmacro_exporter env ncx sloc bindslist))
	(nrepnil (instance class_nrep_nil :nrep_loc sloc))
	)
    (debug_msg mname "normexp export_patmacro mname")
    (debug_msg npmaexp "normexp export_patmacro npmaexp")
    (assert_msg "check mname" (is_a mname class_symbol))
    (multicall 
     (nexpmac nbindms)
     (normal_exp mvalexp env ncx sloc)
     (list_append2list bindslist nbindms)
     (debug_msg nexpmac "normexp_export_patmacro nexpmac")
     (multicall 
      (nexppat nbindps)
      (normal_exp mpatexp env ncx sloc)
      (list_append2list bindslist nbindps)
      (debug_msg nexpmac "normexp_export_patmacro nexppat")
      (let ( (nexpm (normal_exported_patmacro mname npmaexp nexpmac nexppat env ncx sloc bindslist)) )
	(debug_msg nexpm "normexp_export_patmacro nexpm")
	(debug_msg nrepnil "normexp_export_macro final nrepnil")
	(debug_msg bindslist "normexp_export_macro final bindslist")
	(return nrepnil bindslist)
	)
      ))
    ))
(install_method class_source_export_patmacro normal_exp normexp_export_patmacro)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; normalize current_module_environment_container
(defun normexp_current_module_environment_container (recv env ncx psloc)
  (assert_msg "check current_module_environment_container recv" (is_a recv class_source_current_module_environment_container))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_current_module_environment_container recv")
  (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_container
			  :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_container))
    (if (is_a curproc class_nrep_routproc)
	(progn
	  (list_append (unsafe_get_field :nrpro_const curproc) qdatcur)
	  (list_append ncurmodenvlist curproc)
	  ))
    (debug_msg nquasi "normexp_current_module_environment_container nquasi")
    (return nquasi)
    ))
(install_method class_source_current_module_environment_container normal_exp normexp_current_module_environment_container)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; normalize parent_module_environment
(defun normexp_parent_module_environment (recv env ncx psloc)
  (assert_msg "check parent_module_environment recv" (is_a recv class_source_parent_module_environment))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_parent_module_environment  recv")
  (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
			  ))
	)
    (assert_msg "check qdatpar" (is_a qdatpar class_nrep_quasidata_parent_module_environment))
    (if (is_a curproc class_nrep_routproc)
	(list_append (unsafe_get_field :nrpro_const curproc) qdatpar))
    (debug_msg nquasi "normexp_parent_module_environment nquasi")
    (return nquasi)
    ))
(install_method class_source_parent_module_environment normal_exp normexp_parent_module_environment)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; normalize update_current_module_environment_container
(defun normexp_update_current_module_environment_container (recv env ncx psloc)
  (assert_msg "check update_current_module_environment_container recv" (is_a recv class_source_update_current_module_environment_container))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_update_current_module_environment_container recv")
  (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 (if (is_a modctx class_module_context) (unsafe_get_field :mocx_modulename modctx)))
	)
    (if (!= curproc iniproc)
	(progn
	  (error_plain sloc "(UPDATE_CURRENT_MODULE_ENVIRONMENT_CONTAINER) not at toplevel")
	  (return)))
    (let ( (nup (instance class_nrep_update_current_module_environment_container
			  ;; :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_container
				 :loca_location sloc
				 :cmec_comment (strbuf2string discr_string csbuf)))
	   (sgetcurenvbox
	    (instance 
	     class_source_or
	     :loca_location psloc
	     :sor_disj 
	     (tuple
	      scurenvbox
	      (instance 
	       class_source_apply
	       :loca_location psloc
	       :sapp_fun (instance
			  class_source_unsafe_get_field
			  :loca_location psloc
			  :suget_obj (instance
				      class_source_fetch_predefined
				      :loca_location psloc
				      :sfepd_predef 'initial_system_data
				      )
			  :suget_field sysdata_cont_fresh_env
			  )
	       :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_msg bindlist "normexp_update_current_module_environment_container result bindlist")
       (debug_msg clocc "normexp_update_current_module_environment_container result clocc")
       (return clocc bindlist)
       )
      )))
(install_method class_source_update_current_module_environment_container normal_exp normexp_update_current_module_environment_container)

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

;;;; normalize a fetch_predefined
(defun normexp_fetch_predefined (recv env ncx psloc)
  (assert_msg "check fetch_predefined recv" (is_a recv class_source_fetch_predefined))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_fetch_predefined recv")
  (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 ( (boxk (make_box discr_box ())) 
		   )
	      (mapobject_every predefmap
			       (lambda (key val)
				 (if (== val spred) (box_put boxk key))))
	      (if (null (box_content boxk))
		  (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" ()))
	  )
    (let ( (npre (instance class_nrep_predef
			   :nrep_loc sloc
			   :nrpredef spred
			   ))
	   )
      (debug_msg npre "normexp_fetch_predefined result 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)
  (assert_msg "check store_predefined recv" (is_a recv class_source_store_predefined))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_store_predefined recv")
  (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 ( (boxk (make_box discr_box ())) 
		   )
	      (mapobject_every predefmap
			       (lambda (key val)
				 (if (== val spred) (box_put boxk key))))
	      (if (null (box_content boxk))
		  (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" ()))
	  )
    (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_msg nbinds "normexp_store_predefined result nbinds")
       (debug_msg syocc "normexp_store_predefined result syocc")
       (return syocc nbinds)
       ))))
(install_method class_source_store_predefined normal_exp normexp_store_predefined)

(export_values
 check_ctype_nargs
 compile_obj
 create_normcontext
 get_ctype
 normal_exp
 normal_letrec_constructive
 normal_predef
 normalize_tuple
 prepare_constructor_binding
 wrap_normal_let1
 wrap_normal_letseq
 )

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