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

;; file warmelt-normal.bysl -*- Lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(comment "
    Copyright 2008 Free Software Foundation, Inc.
    Contributed by Basile Starynkevitch <basile@starynkevitch.net>

    This file is part of GCC.

    GCC is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 3, or (at your option)
    any later version.

    GCC is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with GCC; see the file COPYING3.  If not see
    <http://www.gnu.org/licenses/>.
")

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

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

(assert_msg "check class_symbol" (is_a class_symbol class_class))
(debug_msg class_symbol "start of warmelt-normal class_symbol")
(debug_msg install_initial_macro "at start of warmelt-normal Install_Initial_Macro")

;;;; ================ 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
  :fields (nrep_loc			;location in source
))

;; a simple stuff is a non-object, a symbol (or keyword or clonedsym),
;; ...
(defclass class_nrep_simple
  :super class_nrep
  :fields (
))

;; a normalized expression should never be the result of normal_exp;
;; it should only appear in bindings!
(defclass class_nrep_expr
  :super class_nrep
  :fields (
))

;; normal applications have simple functions & arguments
(defclass class_nrep_apply
  :super class_nrep_expr
  :fields (napp_fun			;simple function to apply
	   napp_args			;tuple of simple arguments
))

;; normalized multiresult apply
(defclass class_nrep_multiapply
  :super class_nrep_apply
  :fields (nmulapp_bindings 		;a tuple of formal result bindings
	   nmulapp_body			;body normexp
))

;;; normal message sending
(defclass class_nrep_msend
  :super class_nrep_expr
  :fields (nsend_sel		   ;the normalized selector occurrence
	   nsend_recv		   ;the reciever
	   nsend_args		   ;the tuple of simple arguments
))



;; normalized multiresult message send
(defclass class_nrep_multimsend
  :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
  :super class_nrep_expr
  :fields (nchunk_expansion		;the expansion
	   nchunk_primitive		;the primitive
))

;; normal comment is a normalized comment
(defclass class_nrep_comment
  :super class_nrep_expr
  :fields (ncomm_string	;the comment
))

;; normal lets have simple binding & body subexpressions
(defclass class_nrep_let
  :super class_nrep_expr
  :fields (nlet_bindings		;a tuple of class_normlet_binding-s
	   nlet_body
))

;; normal return have a main & supplementary subexpressions
(defclass class_nrep_return
  :super class_nrep_expr
  :fields (nret_main			;main normal expression to return
	   nret_rest			;tuple of normal expr...
))

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

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

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

;; normalized unsafe get field
(defclass class_nrep_unsafe_get_field
  :super class_nrep_expr
  :fields (nuget_obj
	   nuget_field))


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

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

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

;; normalized field assign (in make instance)
(defclass class_nrep_fieldassign
  :super class_nrep
  :fields (nfla_field			;the field
	   nfla_val			;its normalized value
))

;; normalized make instance
(defclass class_nrep_make_instance
  :super class_nrep_expr
  :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_expr
  :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_expr
  :fields (nciter_citerator		;the citerator
	   nciter_locbindings		;the local bindings
	   nciter_chunkbefore		;the expansed chunk before
	   nciter_body			;the normalized body
	   nciter_bodbindings		;normalized body bindings
	   nciter_chunkafter		;the expansed chunk after
))

;;; procedures
(defclass class_nrep_anyproc
  :super class_nrep
  :fields (
	   nproc_body
))


;; the class of the initial procedure
(defclass class_nrep_initproc
  :super class_nrep_anyproc
  :fields (ninit_topl			;list of toplevel nrep
))

;; normal routine procedure
(defclass class_nrep_routproc
  :super class_nrep_anyproc
  :fields (
	   nrpro_name			;name (if any)
	   nrpro_argb			;argument bindings
	   nrpro_closedb		;list of closed bindings
	   nrpro_const			;list of constants
	   nrpro_datarout		;routine data object
	   nrpro_dataclos		;closure data object
	   nrpro_thunklist		;list of thunks to be called when compiling it
))


;;; static normalized predef
(defclass class_nrep_predef
  :super class_nrep_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" 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 basilys_field_object(<obj>,<off>) of obj is not a
;; datainstance and directly to the field if it is a datainstance
(defclass class_nrep_fieldacc
  :super class_nrep_expr
  :fields (naccf_obj			;data for the object to be accessed 
	   naccf_fld			;rank or field to be accessoed
))

;;; data multiple accessor (mostly used for defclass initialization)
;; this translates into basilys_multiple_nth(<mul>,<ix>) if mul is not
;; a datatuple and directly to the component if it is a datatuple
(defclass class_nrep_multacc
  :super class_nrep_expr
  :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_expr
  :fields (nstpd_predef
	   nstpd_value
))

;; normalized update current module environment box
(defclass class_nrep_update_current_module_environment_container
  :super class_nrep_expr
  :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_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_dataclosure
 class_nrep_datainstance
 class_nrep_datakeyword
 class_nrep_dataroutine
 class_nrep_datastring
 class_nrep_datasymbol
 class_nrep_datatuple
 class_nrep_exit
 class_nrep_expr
 class_nrep_fieldacc
 class_nrep_fieldassign
 class_nrep_forever
 class_nrep_if
 class_nrep_initproc
 class_nrep_lambda
 class_nrep_let
 class_nrep_locsymocc
 class_nrep_make_instance
 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_importedval
 class_nrep_store_predefined
 class_nrep_symocc
 class_nrep_unsafe_get_field
 class_nrep_unsafe_put_fields
 class_nrep_update_current_module_environment_container
 )					;end of export normal classes




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

;;; add some data to a normalization context and return it
(defun add_nctx_data (nctx ndata)
  (assert_msg "check nctx" (is_a nctx class_normcontext))
  (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
    ))

;;; keep manually this in sync with enum basilys_globalix_en in basilys.h
;; in alphabetical order
(defprimitive global_ATOM_TRUE                 () :value "(void*)BASILYSG(ATOM_TRUE)")
(defprimitive global_CLASS_CITERATOR           () :value "(void*)BASILYSG(CLASS_CITERATOR)")
(defprimitive global_CLASS_CLASS               () :value "(void*)BASILYSG(CLASS_CLASS)")
(defprimitive global_CLASS_CONTAINER           () :value "(void*)BASILYSG(CLASS_CONTAINER)")
(defprimitive global_CLASS_DISCR               () :value "(void*)BASILYSG(CLASS_DISCR)")
(defprimitive global_CLASS_FIELD               () :value "(void*)BASILYSG(CLASS_FIELD)")
(defprimitive global_CLASS_FORMAL_BINDING      () :value "(void*)BASILYSG(CLASS_FORMAL_BINDING)")
(defprimitive global_CLASS_KEYWORD             () :value "(void*)BASILYSG(CLASS_KEYWORD)")
(defprimitive global_CLASS_LOCATED             () :value "(void*)BASILYSG(CLASS_LOCATED)")
(defprimitive global_CLASS_NAMED               () :value "(void*)BASILYSG(CLASS_NAMED)")
(defprimitive global_CLASS_PRIMITIVE           () :value "(void*)BASILYSG(CLASS_PRIMITIVE)")
(defprimitive global_CLASS_PROPED              () :value "(void*)BASILYSG(CLASS_PROPED)")
(defprimitive global_CLASS_ROOT                () :value "(void*)BASILYSG(CLASS_ROOT)")
(defprimitive global_CLASS_SELECTOR            () :value "(void*)BASILYSG(CLASS_SELECTOR)")
(defprimitive global_CLASS_SEXPR               () :value "(void*)BASILYSG(CLASS_SEXPR)")
(defprimitive global_CLASS_SYMBOL              () :value "(void*)BASILYSG(CLASS_SYMBOL)")
(defprimitive global_CLASS_SYSTEM_DATA         () :value "(void*)BASILYSG(CLASS_SYSTEM_DATA)")
(defprimitive global_CTYPE_CSTRING             () :value "(void*)BASILYSG(CTYPE_CSTRING)")
(defprimitive global_CTYPE_LONG                () :value "(void*)BASILYSG(CTYPE_LONG)")
(defprimitive global_CTYPE_TREE                () :value "(void*)BASILYSG(CTYPE_TREE)")
(defprimitive global_CTYPE_VALUE               () :value "(void*)BASILYSG(CTYPE_VALUE)")
(defprimitive global_CTYPE_VOID                () :value "(void*)BASILYSG(CTYPE_VOID)")
(defprimitive global_DISCR_BOX                 () :value "(void*)BASILYSG(DISCR_BOX)")
(defprimitive global_DISCR_CHARINTEGER         () :value "(void*)BASILYSG(DISCR_CHARINTEGER)")
(defprimitive global_DISCR_CLOSURE             () :value "(void*)BASILYSG(DISCR_CLOSURE)")
(defprimitive global_DISCR_INTEGER             () :value "(void*)BASILYSG(DISCR_INTEGER)")
(defprimitive global_DISCR_LIST                () :value "(void*)BASILYSG(DISCR_LIST)")
(defprimitive global_DISCR_MAPOBJECTS          () :value "(void*)BASILYSG(DISCR_MAPOBJECTS)")
(defprimitive global_DISCR_MAPSTRINGS          () :value "(void*)BASILYSG(DISCR_MAPSTRINGS)")
(defprimitive global_DISCR_METHODMAP           () :value "(void*)BASILYSG(DISCR_METHODMAP)")
(defprimitive global_DISCR_MIXEDINT            () :value "(void*)BASILYSG(DISCR_MIXEDINT)")
(defprimitive global_DISCR_MULTIPLE            () :value "(void*)BASILYSG(DISCR_MULTIPLE)")
(defprimitive global_DISCR_NAMESTRING          () :value "(void*)BASILYSG(DISCR_NAMESTRING)")
(defprimitive global_DISCR_NULLRECV            () :value "(void*)BASILYSG(DISCR_NULLRECV)")
(defprimitive global_DISCR_PAIR                () :value "(void*)BASILYSG(DISCR_PAIR)")
(defprimitive global_DISCR_ROUTINE             () :value "(void*)BASILYSG(DISCR_ROUTINE)")
(defprimitive global_DISCR_SEQCLASS            () :value "(void*)BASILYSG(DISCR_SEQCLASS)")
(defprimitive global_DISCR_SEQFIELD            () :value "(void*)BASILYSG(DISCR_SEQFIELD)")
(defprimitive global_DISCR_STRING              () :value "(void*)BASILYSG(DISCR_STRING)")
(defprimitive global_DISCR_VERBATIMSTRING      () :value "(void*)BASILYSG(DISCR_VERBATIMSTRING)")
(defprimitive global_INITIAL_SYSTEM_DATA       () :value "(void*)BASILYSG(INITIAL_SYSTEM_DATA)")


(defun fill_initial_predefmap (predefmap)
    ;; manually keep in sync  with enum basilys_globalix_en in basilys.h
  ;;; in alphabetical order
    (mapobject_put predefmap (global_ATOM_TRUE)                      'ATOM_TRUE)
    (mapobject_put predefmap (global_CLASS_CITERATOR)                'CLASS_CITERATOR)
    (mapobject_put predefmap (global_CLASS_CLASS)                    'CLASS_CLASS)
    (mapobject_put predefmap (global_CLASS_CONTAINER)                'CLASS_CONTAINER)
    (mapobject_put predefmap (global_CLASS_DISCR)                    'CLASS_DISCR)
    (mapobject_put predefmap (global_CLASS_FIELD)                    'CLASS_FIELD)
    (mapobject_put predefmap (global_CLASS_FORMAL_BINDING)           'CLASS_FORMAL_BINDING)
    (mapobject_put predefmap (global_CLASS_KEYWORD)                  'CLASS_KEYWORD)
    (mapobject_put predefmap (global_CLASS_LOCATED)                  'CLASS_LOCATED)
    (mapobject_put predefmap (global_CLASS_NAMED)                    'CLASS_NAMED)
    (mapobject_put predefmap (global_CLASS_PRIMITIVE)                'CLASS_PRIMITIVE)
    (mapobject_put predefmap (global_CLASS_PROPED)                   'CLASS_PROPED)
    (mapobject_put predefmap (global_CLASS_ROOT)                     'CLASS_ROOT)
    (mapobject_put predefmap (global_CLASS_SELECTOR)                 'CLASS_SELECTOR)
    (mapobject_put predefmap (global_CLASS_SEXPR)                    'CLASS_SEXPR)
    (mapobject_put predefmap (global_CLASS_SYMBOL)                   'CLASS_SYMBOL)
    (mapobject_put predefmap (global_CLASS_SYSTEM_DATA)              'CLASS_SYSTEM_DATA)
    (mapobject_put predefmap (global_CTYPE_CSTRING)                  'CTYPE_CSTRING)
    (mapobject_put predefmap (global_CTYPE_LONG)                     'CTYPE_LONG)
    (mapobject_put predefmap (global_CTYPE_TREE)                     'CTYPE_TREE)
    (mapobject_put predefmap (global_CTYPE_VALUE)                    'CTYPE_VALUE)
    (mapobject_put predefmap (global_CTYPE_VOID)                     'CTYPE_VOID)
    (mapobject_put predefmap (global_DISCR_BOX)                      'DISCR_BOX)
    (mapobject_put predefmap (global_DISCR_CHARINTEGER)              'DISCR_CHARINTEGER)
    (mapobject_put predefmap (global_DISCR_CLOSURE)                  'DISCR_CLOSURE)
    (mapobject_put predefmap (global_DISCR_INTEGER)                  'DISCR_INTEGER)
    (mapobject_put predefmap (global_DISCR_LIST)                     'DISCR_LIST)
    (mapobject_put predefmap (global_DISCR_MAPOBJECTS)               'DISCR_MAPOBJECTS)
    (mapobject_put predefmap (global_DISCR_MAPSTRINGS)               'DISCR_MAPSTRINGS)
    (mapobject_put predefmap (global_DISCR_METHODMAP)                'DISCR_METHODMAP)
    (mapobject_put predefmap (global_DISCR_MIXEDINT)                 'DISCR_MIXEDINT)
    (mapobject_put predefmap (global_DISCR_MULTIPLE)                 'DISCR_MULTIPLE)
    (mapobject_put predefmap (global_DISCR_NAMESTRING)               'DISCR_NAMESTRING)
    (mapobject_put predefmap (global_DISCR_NULLRECV)                 'DISCR_NULLRECV)
    (mapobject_put predefmap (global_DISCR_PAIR)                     'DISCR_PAIR)
    (mapobject_put predefmap (global_DISCR_ROUTINE)                  'DISCR_ROUTINE)
    (mapobject_put predefmap (global_DISCR_SEQCLASS)                 'DISCR_SEQCLASS)
    (mapobject_put predefmap (global_DISCR_SEQFIELD)                 'DISCR_SEQFIELD)
    (mapobject_put predefmap (global_DISCR_STRING)                   'DISCR_STRING)
    (mapobject_put predefmap (global_DISCR_VERBATIMSTRING)           'DISCR_VERBATIMSTRING)
    (mapobject_put predefmap (global_INITIAL_SYSTEM_DATA)            'INITIAL_SYSTEM_DATA)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; create a normalization context
(defun create_normcontext (modctx)
  (let ( (:long maxpredefix (last_globpredef_index))
	 (:long ix 1)
	 (predefmap (make_mapobject discr_mapobjects (+i 19 (*i 2 maxpredefix))))
	 (valmap (make_mapobject discr_mapobjects 350))
	 )
    (assert_msg "check modctx" (is_a modctx class_modulcontext))
    (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  (make_instance class_nrep_initproc
				   :ninit_topl (make_list discr_list)
				   :nrep_loc ()
				   )) 
	   (ncx (make_instance 
		 class_normcontext
		 :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_mapstrings 50)
		 :nctx_keywmap  (make_mapstring discr_mapstrings 40)
		 :nctx_predefmap predefmap
		 :nctx_valmap valmap
		 :nctx_valbindmap (make_mapobject discr_mapobjects 20)
		 ;; we need a symbcachemap for the toplevel expressions
		 :nctx_symbcachemap (make_mapobject discr_mapobjects 30)
		 :nctx_curproc inipro
		 :nctx_modulcontext modctx
		 :nctx_qdatcurmodenvbox (make_instance class_nrep_quasidata_current_module_environment_container
						       )
		 :nctx_qdatparmodenv (make_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_normcontext))
  ;; is a no-op
  (debug_msg recv "normexp_identical recv")
  recv)

(install_method discr_anyrecv 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_normcontext))
  (let ( (normnull (make_instance class_nrep_nil :nrep_loc psloc)) )
    (debug_msg normnull "normexp_null normnull")
    normnull
))
(install_method discr_nullrecv 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_normcontext))
  (debug_msg recv "normexp_src_catchall recv" )
  (let ( (myclass (discrim recv))
	 (myclassname (unsafe_get_field :named_name myclass)) )
    (error_strv (unsafe_get_field :src_loc recv) 
		"unimplemented normalization for " myclassname)
    (assert_msg "normexp_src_catchall unimplemented normexp for src" ())
    ))
(install_method class_src normal_exp normexp_src_catchall)

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

;;; 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_anyrecv get_ctype gectyp_anyrecv)

(defun gectyp_root (recv env) ctype_value)
(install_method class_root get_ctype gectyp_root)

;; integers are ctype_long
(defun gectyp_integer (recv env) 
  (debug_msg 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_normcontext))
  (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")
		  (assert_msg "check nbinds" (is_list_or_null nbinds))
		  (assert_msg "check norcomp not nrep_expr" (is_not_a norcomp class_nrep_expr))
		  (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_normlet_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_normlet_binding))))
  (let ( (wnlet
	  (make_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_normlet_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_normlet_binding))))
  (if 
      (and (is_list bindlist)
	   (is_pair (list_first bindlist)))
      (let ( (wnlet 
	      (make_instance class_nrep_let
			     :nrep_loc loc
			     :nlet_bindings (list_to_multiple bindlist)
			     :nlet_body (make_tuple1 discr_multiple nexp)))
	     )
	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))
     ))
)))

(export_values
 create_normcontext
 normal_exp
 get_ctype
 normalize_tuple
 wrap_normal_letseq
 wrap_normal_let1
 check_ctype_nargs
 compile_obj
)


; 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)
  (multicall
   (bind procs)
   (find_enclosing_env env recv)
   (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 (the_null))))
   (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 
		      (make_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
		      (make_instance class_nrep_constocc
				     :nrep_loc psloc
				     :nocc_symb recv
				     :nocc_bind bind
				     :nocc_ctyp ctype_value
				     :ncloc_procs procs))
		    )
		;; cache the result
		(mapobject_put sycmap recv fxocc)
		(debug_msg fxocc "normexp_symbol 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
	    (let ( 
		  )
		;; cache the result
		(mapobject_put sycmap recv bvar)
		(debug_msg bvar "normexp_symbol value bvar")
		bvar
	      )
	    )))
      ;; the procs is a non-empty list, so the symbol is closed
      ( (and (is_list procs)
	     (is_pair (list_first procs)))
	;; check that a closed symbol is always a value
	(let ( (bty
		(cond ( (is_a bind class_formal_binding)
			(unsafe_get_field :fbind_type bind) )
		      ( (is_a bind class_let_binding)
			(unsafe_get_field :letbind_type bind))
		      (:else ()))) 
	       )
	  (if bty 
	      (if (!= bty ctype_value)
		  (error_strv psloc
			      "closed variable has non value type (boxing required)"
			      (unsafe_get_field :named_name recv)
			      )))
	  (setq bty ctype_value)
	  (if (is_a bind class_fixed_binding)
	      (let ( (fxocc
		      (make_instance class_nrep_constocc
				     :nrep_loc psloc
				     :nocc_symb recv
				     :nocc_bind bind
				     :nocc_ctyp ctype_value
				     :ncloc_procs procs)) )
		;; cache the result
		(mapobject_put sycmap recv fxocc)
		(debug_msg 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 
		    (make_instance class_nrep_closedocc
				   :nrep_loc psloc
				   :nocc_symb recv
				   :nocc_ctyp ctype_value
				   :nocc_bind bind
				   :ncloc_procs procs)) 
		   )
	      ;; cache the result
	      (mapobject_put sycmap recv clocc)
	      ;; put the closed occurrence if needed in the closed list of each proc
	      (list_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
		(make_instance class_nrep_locsymocc
			       :nrep_loc psloc
			       :nocc_ctyp (unsafe_get_field :fbind_type bind) 
			       :nocc_symb recv
			       :nocc_bind bind) ) )
	  ;; cache the result & return it
	  (mapobject_put sycmap recv syocc)
	  syocc
	  ))
      ;; let binding is a local
      ( (is_a bind class_let_binding)
	(let ( (syocc
		(make_instance class_nrep_locsymocc
			       :nrep_loc psloc
			       :nocc_ctyp (unsafe_get_field :letbind_type bind)
			       :nocc_symb recv
			       :nocc_bind bind) ) )
	  ;; cache the result & return it
	  (mapobject_put sycmap recv syocc)
	  syocc
	  ))
      ;; previous function binding at toplevel
      ( (is_a bind class_function_binding)
	(debug_msg bind "normexp_symbol function bind")
	(let ( (fubdat (unsafe_get_field :fubind_fundata bind)) )
	  (if (null fubdat)
	      (error_strv psloc "unresolved forward function reference to"
			  (unsafe_get_field :named_name recv)
			  ))
	  (assert_msg "normexp_symbol check fubdat" (is_a fubdat class_nrep_dataclosure))
	  ;; cache the result & return it
	  (mapobject_put sycmap recv fubdat)
	  fubdat
	  ))
      ;; previous primitive binding at toplevel
      ( (is_a bind class_primitive_binding)
	(let ( (pribidat (unsafe_get_field :pbind_primdata bind)) )
	  (if (null pribidat)
	      (error_strv psloc "unresolved forward primitive reference to"
			  (unsafe_get_field :named_name recv)
			  )
	    )
	  (assert_msg "normexp_symbol check pribdat" (is_a pribidat class_nrep_datainstance))
	  ;; cache the result & return it
	  (mapobject_put sycmap recv pribidat)
	  pribidat))
      ;; previous class binding at toplevel
      ( (is_a bind class_class_binding)
	(let ( (cldat (unsafe_get_field :cbind_cladata bind)) )
	  (if (null cldat)
	      (error_strv psloc "unresolved forward class reference to"
			  (unsafe_get_field :named_name recv)
			  )
	    )
	  (assert_msg "normexp_symbol check cldat" (is_a cldat class_nrep_datainstance))
	  ;; cache the result & return it
	  (mapobject_put sycmap recv cldat)
	  cldat))
      ;; previous field binding at toplevel
      ( (is_a bind class_field_binding)
	(let ( (fdat (unsafe_get_field :flbind_fdata bind)) )
	  (if (null fdat)
	      (error_strv psloc "unresolved forward field reference to"
			  (unsafe_get_field :named_name recv)
			  )
	    )
	  (assert_msg "normexp_symbol check fdat" (is_a fdat class_nrep_datainstance))
	  ;; cache the result & return it
	  (mapobject_put sycmap recv fdat)
	  fdat))
      ;; previous selector binding at toplevel
      ( (is_a bind class_selector_binding)
	(let ( (seldat (unsafe_get_field :sbind_selectordata bind)) )
	  (if (null seldat)
	      (error_strv psloc "unresolved forward selector reference to"
			  (unsafe_get_field :named_name recv)
			  )
	    )
	  (assert_msg "normexp_symbol check seldat" (is_a seldat class_nrep_datainstance))
	  ;; cache the result & return it
	  (mapobject_put sycmap recv seldat)
	  seldat))
      ;; previous instance binding at toplevel
      ( (is_a bind class_instance_binding)
	(let ( (insdat (unsafe_get_field :ibind_data bind)) )
	  (if (null insdat)
	      (error_strv psloc "unresolved forward instance reference to"
			  (unsafe_get_field :named_name recv)
			  )
	    )
	  (assert_msg "normexp_symbol check insdat" (is_a insdat class_nrep_datainstance))
	  ;; cache the result & return it
	  (mapobject_put sycmap recv insdat)
	  insdat)
	)
      ;; all other cases are constants
      (:else 
       (debug_msg bind "normexp_symbol const? bind")
       (let ( (kocc
	       (make_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 primitive invocation
(defun normexp_primitive (recv env ncx psloc)
  (debug_msg recv "normexp_primitive recv")
  (assert_msg "check prim recv" (is_a recv class_src_primitive))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (let ( (sloc (unsafe_get_field :src_loc recv)) 
	 (soper (unsafe_get_field :sprim_oper recv))
	 (sargs (unsafe_get_field :sprim_args recv)) 
	 )
    (assert_msg "check soper" (is_a soper class_primitive))
    (multicall 
     (nargs nbind)
     (normalize_tuple sargs env ncx sloc)
     (let ( (sopnamstr (unsafe_get_field :named_name soper))
	    (sopformals (unsafe_get_field :prim_formals soper))
	    (soptype (unsafe_get_field :prim_type soper))
	    (sopexp (unsafe_get_field :prim_expansion soper)) 
	    (:long nbarg (multiple_length nargs))
	    (:long nbexp (multiple_length sopexp))
	    )
       (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 (the_null)))
	   )
       (let ( (bmap (make_mapobject  discr_mapobjects (+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))
	    (let ( (forarg (unsafe_get_field :binder forb))
		   (actarg (multiple_nth nargs ix)) )
	      (debug_msg forarg "normexp_primitive forarg")
	      (debug_msg actarg "normexp_primitive actarg")
	      (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 
				(debug_msg recv "normexp_primitive recv unbound symbol in expansion")
				(debug_msg excu "normexp_primitive excu")
				(error_strv sloc "unbound 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))
	    ))
	 (let ( (csym (clone_symbol  (unsafe_get_field :sdef_name soper))) 
		(cbind (make_instance class_normlet_binding
				      :letbind_loc sloc
				      :binder csym
				      :letbind_type soptype 
				      :letbind_expr 
				      (make_instance class_nrep_chunk
						     :nrep_loc sloc
						     :nchunk_expansion expargs
						     :nchunk_primitive soper
						     ))) 
		(clocc (make_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_src_primitive normal_exp normexp_primitive)
(install_method class_nrep_chunk get_ctype 
		(lambda (recv env)
		  (let ( ( prim (unsafe_get_field :nchunk_primitive recv)) )
		    (assert_msg "check prim" (is_a prim class_primitive))
		    (unsafe_get_field :prim_type prim))))





;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; normalize an application
(defun normexp_apply (recv env ncx psloc)
  (assert_msg "check apply recv" (is_a recv class_src_apply))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (let ( (sloc (unsafe_get_field :src_loc recv)) 
	 (sfun (unsafe_get_field :sapp_fun recv))
	 (sargs (unsafe_get_field :sapp_args recv))
	 (sfusymb (if (is_a sfun class_symbol) sfun '_fun_))
	 )
    (multicall 
     (nfun nbindfun)
     (normal_exp sfun env ncx sloc)
     (assert_msg "check nbindfun" (is_list_or_null nbindfun))
     (multicall
      (nargs nbindargs)
      (normalize_tuple sargs env ncx sloc)
      (assert_msg "check nbindargs" (is_list_or_null nbindargs))
      (check_ctype_nargs nargs env sloc)
      (setq nbindargs (list_append2list nbindargs nbindfun))
      (let ( (csym (clone_symbol sfusymb))
	     (cbind (make_instance class_normlet_binding
				   :letbind_loc sloc
				   :binder csym
				   :letbind_type ctype_value 
				   :letbind_expr 
				   (make_instance class_nrep_apply
						  :nrep_loc sloc
						  :napp_fun nfun
						  :napp_args nargs
						  ))) 
	     (clocc  (make_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_src_apply normal_exp normexp_apply)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; normalize a message send
(defun normexp_msend (msnd env ncx psloc)
  (assert_msg "check env" (is_a msnd class_src_msend))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  ; (debug_msg ncx "normexp_msend ncx")
  (debug_msg msnd "normexp_msend msnd")
  (let ( (msrecv (unsafe_get_field :msend_recv msnd))
	 (msargs (unsafe_get_field :msend_args msnd))
	 (selnam (unsafe_get_field :msend_selsymb msnd))
	 (curproc (unsafe_get_field :nctx_curproc ncx))
	 (sloc (unsafe_get_field :src_loc msnd))
	 (nsel (normexp_symbol selnam env ncx sloc))
	 )
    (debug_msg curproc "normexp_msend curproc")
    ;;;; 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 (
	    (csym (clone_symbol selnam)) 
	    (nsend (make_instance class_nrep_msend
				  :nrep_loc sloc
				  :nsend_sel nsel
				  :nsend_recv nrecv
				  :nsend_args nargs)) 
	     (cbind (make_instance class_normlet_binding
				   :letbind_loc sloc
				   :binder csym
				   :letbind_type ctype_value 
				   :letbind_expr nsend))
	    (clocc  (make_instance  class_nrep_locsymocc
				    :nrep_loc sloc
				    :nocc_ctyp ctype_value
				    :nocc_symb csym
				    :nocc_bind cbind)) 
	    )
	(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_src_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_src_return))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (let ( (sloc (unsafe_get_field :src_loc recv)) 
	 (srets (unsafe_get_field :sreturn_body recv))
	 (:long nbrets (multiple_length srets))
	 (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 (make_instance class_normlet_binding
			       :letbind_loc sloc
			       :binder csym
			       :letbind_type ctype_value 
			       ;; :letbind_expr is filled later
			       ))
	 (clocc (make_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 
	       (make_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
		 (make_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_src_return normal_exp normexp_return)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; normalize an if
(defun normexp_if (recv env ncx psloc)
  (assert_msg "check if recv" (is_a recv class_src_if))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_if recv")
  (let ( (sloc (unsafe_get_field :src_loc recv))
	 (stest (unsafe_get_field :sif_test recv))
	 (ctypif ctype_void)
	 (sthen (unsafe_get_field :sif_then recv))
	 )
    (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  (make_instance  class_nrep_locsymocc
				       :nrep_loc sloc
				       :nocc_ctyp ctypif
				       :nocc_symb csym)) 
	       (wthen (wrap_normal_let1 nthen nbindthen sloc))
	       (cbind (make_instance class_normlet_binding
				     :letbind_loc sloc
				     :binder csym
				     :letbind_type ctypif 
				     :letbind_expr 
				     (make_instance class_nrep_if
						    :nrep_loc sloc
						    :nif_test ntest
						    :nif_then wthen
						    :nif_else (the_null)
						    :nif_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_src_if normal_exp normexp_if)
(install_method class_nrep_if get_ctype 
		(lambda (recv env) (unsafe_get_field :nif_ctyp recv)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; normalize an ifelse
(defun normexp_ifelse (recv env ncx psloc)
  (assert_msg "check if recv" (is_a recv class_src_ifelse))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_ifelse recv")
  (let ( (sloc (unsafe_get_field :src_loc recv))
	 (stest (unsafe_get_field :sif_test recv))
	 (ctypif ctype_void)
	 (sthen (unsafe_get_field :sif_then recv))
	 (selse (unsafe_get_field :sif_else recv))
	 )
    (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  (make_instance  class_nrep_locsymocc
					:nrep_loc sloc
					:nocc_ctyp ctypif
					:nocc_symb csym)) 
		(wthen (wrap_normal_let1 nthen nbindthen sloc))
		(welse (wrap_normal_let1 nelse nbindelse sloc))
		(cbind (make_instance class_normlet_binding
				      :letbind_loc sloc
				      :binder csym
				      :letbind_type ctypif 
				      :letbind_expr 
				      (make_instance class_nrep_if
						     :nrep_loc sloc
						     :nif_test ntest
						     :nif_then wthen
						     :nif_else welse
						     :nif_ctyp ctypif
						     ))) )
	   (unsafe_put_fields clocc :nocc_bind cbind)
	   (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_src_ifelse normal_exp normexp_ifelse)


;;;;;;;;;;;;;;;; normalize a cppif
(defun normexp_cppif (recv env ncx psloc)
  (assert_msg "check cppif recv" (is_a recv class_src_cppif))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_cppif recv")
  (let ( (sloc (unsafe_get_field :src_loc 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  (make_instance  class_nrep_locsymocc
					   :nrep_loc sloc
					   :nocc_ctyp ctypif
					   :nocc_symb csym)) 
		   (wthen (wrap_normal_let1 nthen nbindthen sloc))
		   (welse (wrap_normal_let1 nelse nbindelse sloc))
		   (cbind (make_instance class_normlet_binding
					 :letbind_loc sloc
					 :binder csym
					 :letbind_type ctypif 
					 :letbind_expr 
					 (make_instance class_nrep_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_src_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_src_or))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_or recv")
  (let ( 
	(boxorcount (make_integerbox discr_integer (the_callcount)))
	(sloc (unsafe_get_field :src_loc recv))
	(sdisj (unsafe_get_field :sor_disj recv))
	(:long nbdisj (multiple_length sdisj))
	(:long ix (-i nbdisj 1))
	(norbox (make_box discr_box (the_null)))
	(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))
	      (the_null)
	      )
	  (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 (make_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)
			  :nif_ctyp ctypcur
			  )
			 )
		  (csymor (clone_symbol 'or_))
		  (corbind (make_instance 
			    class_normlet_binding
			    :binder csymor
			    :letbind_loc sloc
			    :letbind_type ctypcur
			    :letbind_expr nifor))
		  (corocc (make_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)
	      (the_null)
	      )
	    )
	  )
	)
       )
     )
    (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_src_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_src_progn))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_progn recv")
  (let ( (sloc (unsafe_get_field :src_loc recv))
	 (sbody (unsafe_get_field :sprogn_body recv))
	 (:long lnbody (multiple_length sbody)) 
	 (boxlnbody (make_integerbox discr_integer lnbody))
	 )
    (if (<=i lnbody 0)
	(let ( (onull (make_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 (make_instance class_normlet_binding
				   :binder csym
				   :letbind_loc sloc
				   :letbind_type lastctyp
				   :letbind_expr (make_instance class_nrep_progn
								:nrep_loc sloc
								:nprogn_seq nallbutlast
								:nprogn_last nlast)))
	     (clocc (make_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_src_progn normal_exp normexp_progn)
(install_method class_nrep_progn get_ctype 
		(lambda (recv env) (get_ctype (unsafe_get_field :nprogn_last recv) env)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;	 
;;;;;; normalize a LET
(defun normexp_let (recv  env ncx psloc)
  (assert_msg "check let recv" (is_a recv class_src_let))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_let recv")
  (let ( (sloc (unsafe_get_field :src_loc recv))
	 (sbindings (unsafe_get_field :slet_bindings recv))
	 (sbody (unsafe_get_field :slet_body recv)) 
	 (newenv (fresh_env env))
	 (bindlist (make_list discr_list))
	 )
    (multiple_every 
     sbindings
     (lambda (sb :long sbix)
       (assert_msg "check sb" (is_a sb class_src_letbinding))
       (let ( (sbloc (unsafe_get_field :src_loc sb))
	      (sbtyp (unsafe_get_field :sletb_type sb))
	      (sbinder (unsafe_get_field :sletb_binder sb))
	      (sbexpr (unsafe_get_field :sletb_expr sb)) 
	      )
	 (multicall
	  (nbdexpr nbindings)
	  (normal_exp sbexpr newenv ncx sbloc)
	  (let ( (lastnbinding (pair_head (list_last nbindings))) )
	    ;; common case of a normalized apply or primitive, hence a
	    ;; gensymed variable which is the last in the nbindings
	    (if (and
		 (is_a lastnbinding class_normlet_binding)
		 (is_a nbdexpr class_nrep_locsymocc)
		 (== (unsafe_get_field :binder lastnbinding) 
		     (unsafe_get_field :nocc_symb nbdexpr))
		 )
		(let ( (lastnormexp (unsafe_get_field :letbind_expr nbdexpr)) )
		  (list_every
		   nbindings
		   (lambda (b)
		     (if (!= b lastnbinding)
			 (list_append bindlist b))))
		  (let ( (newcbnd
			  (make_instance class_normlet_binding
					 :binder sbinder
					 :letbind_type (unsafe_get_field :letbind_type lastnbinding)
					 :letbind_expr (unsafe_get_field :letbind_expr lastnbinding)
					 :letbind_loc (unsafe_get_field :letbind_loc lastnbinding)))
			 )
		    (list_append bindlist newcbnd)
		    (put_env newenv newcbnd)
		    )
		  )
	      (progn
;;; otherwise, eg a plain constant, a complex if...
		(list_append2list bindlist  nbindings)
		(let ( (newpbnd 
			(make_instance class_normlet_binding
				       :binder sbinder
				       :letbind_type sbtyp
				       :letbind_expr nbdexpr
				       :letbind_loc sbloc)) )
		  (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_normlet_binding))))
;;; remove every locallly 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
	    (make_instance class_nrep_let
			   :nrep_loc sloc
			   :nlet_bindings (list_to_multiple bindlist discr_multiple)
			   :nlet_body nbody))
	   (cbind (make_instance class_normlet_binding
				 :binder csym
				 :letbind_loc sloc
				 :letbind_type nlastyp
				 :letbind_expr nlet))
	   (clocc (make_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_src_let normal_exp normexp_let)
(install_method class_nrep_let get_ctype 
		(lambda (recv env)
		  (let ( (lbod (unsafe_get_field :nlet_body recv))
			 (:long lenb (multiple_length lbod)) )
		    (if (<=i lenb 0) ctype_void
		      (get_ctype (multiple_nth lbod (-i lenb 1)) env)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; normalize an UNSAFE_GET_FIELD
(defun normexp_unsafe_get_field (recv env ncx psloc)
  (assert_msg "check unsafegetfield recv" (is_a recv class_src_unsafe_get_field))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp unsafeget recv")
  (let ( (sloc   (unsafe_get_field :src_loc recv))
	 (sobj   (unsafe_get_field :suget_obj recv))
	 (sfld   (unsafe_get_field :suget_field recv)) 
	 ) 
    (assert_msg "check sfld" (is_a sfld class_field))
    (multicall
     (nobj nbind)
     (normal_exp sobj env ncx sloc)
     (if (null nbind) (setq nbind (make_list discr_list)))
     (let ( (csym (clone_symbol (unsafe_get_field :named_name sfld)))
	    (cbind (make_instance class_normlet_binding
				  :binder csym
				  :letbind_loc sloc
				  :letbind_type ctype_value
				  :letbind_expr 
				  (make_instance class_nrep_unsafe_get_field
						 :nrep_loc sloc
						 :nuget_obj nobj
						 :nuget_field sfld)))
	    (clocc (make_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_src_unsafe_get_field normal_exp normexp_unsafe_get_field)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; normalize an UNSAFE_PUT_FIELDS
(defun normexp_unsafe_put_fields (recv env ncx psloc)
  (assert_msg "check unsafeputfields recv" (is_a recv class_src_unsafe_put_fields))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_unsafe_put_fields recv")
  (let ( (sloc   (unsafe_get_field :src_loc 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 (make_instance class_normlet_binding
			       :binder csym
			       :letbind_loc sloc
			       :letbind_type ctype_void
			       ;; letbind_expr filled later
			       :letbind_expr ()))
	 (clocc (make_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_src_fieldassign))
	(let ( (fld (unsafe_get_field :sfla_field fla))
	       (exp (unsafe_get_field :sfla_expr fla)) )
	  (assert_msg "check fld" (is_a fld class_field))
	  (multicall
	   (nexp nexpbind)
	   (normal_exp exp env ncx sloc)
	   (list_append2list nbindlist  nexpbind)
	   (let ( (nfla (make_instance class_nrep_fieldassign
				       :nrep_loc sloc
				       :nfla_field fld
				       :nfla_val nexp)) )
	     (multiple_put_nth nfields ix nfla)
	     )))))
     (let ( (npuf (make_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_src_unsafe_put_fields normal_exp normexp_unsafe_put_fields)
(install_method class_nrep_unsafe_put_fields get_ctype (lambda (recv env) ctype_void))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; normalize a setq
(defun normexp_setq (recv env ncx psloc)
  (assert_msg "check setq recv" (is_a recv class_src_setq))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp setq recv")
  (let ( (sloc   (unsafe_get_field :src_loc recv))
	 (svar   (unsafe_get_field :sstq_var recv))
	 (sexp   (unsafe_get_field :sstq_expr recv)) ) 
    (assert_msg "check svar" (is_a svar class_symbol))
    (let ( (nvar (normexp_symbol svar env ncx sloc)) 
	   (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  (make_instance class_normlet_binding
				     :binder csym
				     :letbind_loc sloc
				     :letbind_type varctyp
				     :letbind_expr
				     (make_instance class_nrep_setq
						    :nrep_loc sloc
						    :nstq_var nvar
						    :nstq_exp nexp)))
	      (clocc (make_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_src_setq normal_exp normexp_setq)
(install_method class_nrep_setq get_ctype 
		(lambda (recv env)
		  (get_ctype (unsafe_get_field :nstq_var recv) env)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a make_instance
(defun normexp_make_instance (recv env ncx psloc)
  (assert_msg "check make_instance recv" (is_a recv class_src_make_instance))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_make_instance recv" )
  (let ( (sloc (unsafe_get_field :src_loc recv))
	 (sclass (unsafe_get_field :smins_class recv))
	 (sclabind (unsafe_get_field :smins_clabind recv))
	 (sfields (unsafe_get_field :smins_fields recv))
	 (sclasym (if (is_a sclabind class_any_binding) (unsafe_get_field :binder sclabind)))
	 (cladata (if (is_a sclasym class_symbol) 
		      (normal_exp sclasym env ncx sloc)))
	 (bindlist (make_list discr_list))
	 )
    (if (not (is_a cladata class_nrep))
	(progn
	  (error_strv sloc "invalid class in make_instance" (unsafe_get_field :named_name sclass))
	  (return (the_null))))
    (let ( (nfields 
	    (multiple_map 
	     sfields 
	     (lambda (curflda :long curk)
	       (assert_msg "check curflda" (is_a curflda class_src_fieldassign))
	       (let ( (curfloc (unsafe_get_field :src_loc curflda))
		      (curfield (unsafe_get_field :sfla_field curflda))
		      (curexp (unsafe_get_field :sfla_expr curflda)) )
		 (if (null curfloc) (setq curfloc sloc))
		 (multicall
		  (nexp nbind)
		  (normal_exp curexp env ncx curfloc)
		  (assert_msg "check nbind" (is_list_or_null nbind))
		  (list_append2list bindlist  nbind)
		  (make_instance class_nrep_fieldassign
				 :nrep_loc curfloc
				 :nfla_field curfield
				 :nfla_val nexp)
		  )))))
	   (nmkins 
	    (make_instance class_nrep_make_instance
			   :nrep_loc sloc
			   :nmins_class sclass
			   :nmins_cladata cladata
			   :nmins_fields nfields))
	   (csym (clone_symbol 'inst_))
	   (cbind (make_instance class_normlet_binding
				 :binder csym
				 :letbind_loc sloc
				 :letbind_type ctype_value
				 :letbind_expr nmkins))
	   (clocc (make_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_make_instance result clocc")
      (debug_msg bindlist "normexp_make_instance result bindlist")
      (return clocc bindlist)
      )
    )
  )
(install_method class_src_make_instance normal_exp normexp_make_instance)
(install_method class_src_make_instance get_ctype 
		(lambda (recv env) ctype_value))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a forever

(defun normexp_forever (recv env ncx psloc)
  (assert_msg "check forever recv" (is_a recv class_src_forever))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_forever recv" )
  (let ( (sloc   (unsafe_get_field :src_loc recv))
	 (slbind (unsafe_get_field :slabel_bind recv))
	 (sbody (unsafe_get_field :sfrv_body recv))
	 (newenv (fresh_env env))
	 )
    (assert_msg "check slbind" (is_a slbind class_label_binding))
    (put_env newenv slbind)
    (let ( (resy (clone_symbol (unsafe_get_field :binder slbind))) )
      (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_clonedsymbol))
      (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 (make_tuple1 discr_multiple 
				   (wrap_normal_letseq nbody nbodbindings sloc)))
	     (csym (clone_symbol 'forever_))
	     (nforever (make_instance class_nrep_forever
				      :nrep_loc sloc
				      :nforever_bind slbind
				      :nforever_body resbody
				      :nforever_result resy)) 
	     (cbind (make_instance class_normlet_binding
				   :binder csym
				   :letbind_loc sloc
				   :letbind_type ctype_value
				   :letbind_expr nforever))
	     (clocc (make_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_src_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 2))
(defun normexp_exit (recv env ncx psloc)
  (assert_msg "check exit recv" (is_a recv class_src_exit))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_exit recv")
  (let ( (sloc   (unsafe_get_field :src_loc recv))
	 (slbind (unsafe_get_field :slabel_bind recv))
	 (sbody (unsafe_get_field :sexi_body recv))
	 (newenv (fresh_env env))
	 )
    (assert_msg "check slbind" (is_a slbind class_label_binding))
    (put_env newenv slbind)
    (multicall
     (nbody nbodbindings)
     (normalize_tuple sbody newenv ncx sloc)
     (if (null nbodbindings)
	 (setq nbodbindings (make_list discr_list)))
     ;; the only interesting value of nbody is the last one
     (let ( (nexit (make_instance class_nrep_exit
				  :nrep_loc sloc
				  :nexit_bind slbind
				  :nexit_val (multiple_nth nbody (-i (multiple_length nbody) 1)))) 
	    (csym (clone_symbol 'exit_))
	    (cbind (make_instance class_normlet_binding
				  :binder csym
				  :letbind_loc sloc
				  :letbind_type ctype_void
				  :letbind_expr nexit))
	    (clocc (make_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_src_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_src_compilewarning))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_compile_warning recv")
  (let ((sloc   (unsafe_get_field :src_loc 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_src_compilewarning normal_exp normexp_compilewarning)
(install_method class_src_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)
	    (make_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)
	(make_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 (make_instance class_nrep_locsymocc 
					   :nrep_loc loc
					   :nocc_symb rclosym
					   :nocc_ctyp ctype_value))
		    (retn (make_instance class_nrep_return
					 :nrep_loc loc
					 :nret_main rclocc
					 ))
		    (rbind (make_instance class_normlet_binding
					  :binder rclosym
					  :letbind_type ctype_value
					  :letbind_expr lastcomp
					  :letbind_loc loc
					  ))
		    (rbintup (make_tuple1 discr_multiple rbind))
		    (rlet (make_instance class_nrep_let
					 :nrep_loc loc
					 :nlet_bindings rbintup
					 :nlet_body (make_tuple1 discr_multiple retn)))
		    )
	       (unsafe_put_fields rclocc :nocc_bind rbind)
	       (multiple_put_nth 
		tup  (-i tuplen 1)
		rlet)
	       (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_src_defun))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_defun recv")
  (let ( (sloc (unsafe_get_field :src_loc recv))
	 (snam (unsafe_get_field :sdef_name recv))
	 (sformals (unsafe_get_field :sformal_args recv))
	 (sbody (unsafe_get_field :sfun_body recv))
	 (sfubind (find_env env snam))
	 (newenv (fresh_env env))
	 (oldproc (unsafe_get_field :nctx_curproc ncx))
	 (oldsymbcache (unsafe_get_field :nctx_symbcachemap ncx))
	 (closblis (make_list discr_list))
	 (nproc (make_instance class_nrep_routproc
;;; dont forget to put the nil fields at end
			       :nrep_loc sloc
			       :nproc_body (the_null) ;filled later
			       :nrpro_name snam
			       :nrpro_argb sformals
			       :nrpro_closedb closblis
			       :nrpro_const (make_list discr_list)
			       :nrpro_thunklist (make_list discr_list)
			       :nrpro_datarout (the_null) ; filled below
			       :nrpro_dataclos (the_null) ; filled below
			       ))
	 (ndatarout (make_instance class_nrep_dataroutine
				   :ndata_name snam
				   :ndata_discrx (normal_predef discr_routine ncx sloc "discr_routine")
				   :ndrou_proc nproc
				   ))
	 (ndataclos (make_instance class_nrep_dataclosure
				   :ndata_name snam
				   :ndata_discrx  (normal_predef discr_closure ncx sloc "discr_closure")
				   :ndclo_proc nproc
				   :ndclo_closv (the_null) ;filled below
				   ))
	 )
    (unsafe_put_fields ncx 
		       :nctx_curproc nproc
		       :nctx_symbcachemap (make_mapobject discr_mapobjects 40))
    (add_nctx_data ncx ndatarout)
    (add_nctx_data ncx ndataclos)
    (assert_msg "check sfubind" (is_a sfubind class_function_binding))
    (unsafe_put_fields nproc :nrpro_datarout ndatarout :nrpro_dataclos ndataclos)
    (multiple_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)
    ;; 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 :fubind_fundata ndataclos)
     (debug_msg nproc "normexp_defun return nproc")
     (return nproc ())
     )
    ))
(install_method class_src_defun normal_exp normexp_defun)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a LAMBDA
(defun normexp_lambda (recv env ncx psloc)
  (assert_msg "check lambda recv" (is_a recv class_src_lambda))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_lambda recv")
  (let ( (sloc (unsafe_get_field :src_loc recv))
	 (sargs (unsafe_get_field :slam_argbind recv))
	 (sbody (unsafe_get_field :slam_body recv))
	 (savedcachemap (unsafe_get_field :nctx_symbcachemap ncx))
	 (csym (clone_symbol 'lambda_))
	 (clocc (make_instance class_nrep_locsymocc
			       :nrep_loc sloc
			       :nocc_ctyp ctype_value
			       :nocc_symb csym)) 
	 (newenv (fresh_env env))
	 (oldproc (unsafe_get_field :nctx_curproc ncx))
	 (closedblist (make_list discr_list))
	 (nproc (make_instance class_nrep_routproc
			       :nrep_loc sloc
			       :nproc_body (the_null) ;filled later
			       :nrpro_name csym
			       :nrpro_argb sargs
			       :nrpro_closedb closedblist
			       :nrpro_const (make_list discr_list)
			       :nrpro_datarout (the_null) ; filled below
			       :nrpro_dataclos (the_null) ; not filled
			       :nrpro_thunklist (make_list discr_list)
			       ))
	 (ndatarout (make_instance class_nrep_dataroutine
				   :ndata_name 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_mapobjects 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)
    ;; 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
		      (make_instance class_nrep_constant
				     :nrep_loc sloc
				     :nconst_sval recv
				     :nconst_data ndatarout
				     :nconst_proc oldproc)))
	   (clovtup 
	    (list_to_multiple closedblist
			      discr_multiple
			      (lambda (bnd)
				(assert_msg "normexp_lambda check bnd" (is_a bnd class_any_binding))
				(let ( (sy (unsafe_get_field :binder bnd)) 
				       ;; since sy is a symbol, its normalized form does not add any binding
				       ;; we normalize it in the *old* environment, not the new one
				       (nsy (normal_exp sy env ncx sloc))
				       )
				  nsy))))
	   (nlambda (make_instance class_nrep_lambda 
				   :nrep_loc sloc
				   :nlambda_proc nproc
				   :nlambda_constrout (if insideflag krout ndatarout)
				   :nlambda_closedv clovtup
				   ))
	   (cbind (make_instance class_normlet_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_src_lambda normal_exp normexp_lambda)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun normexp_multicall (recv env ncx psloc)
  (assert_msg "check multicall recv" (is_a recv class_src_multicall))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_multicall recv")
  (let ( (sloc (unsafe_get_field :src_loc 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))
	 )
    (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_normlet_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_normlet_binding))
	  (if (== ncallsym (unsafe_get_field :binder cbnd))
	      (let ( (nrealcall (unsafe_get_field :letbind_expr cbnd)) )
		(box_put nboxcall nrealcall)
		())
	    (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 (make_instance class_normlet_binding
				      :binder csym
				      :letbind_loc sloc
				      :letbind_type lastntype
					; :letbind_expr  filled below
				      ))
		(clocc (make_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_src_apply)
	       (assert_msg "normexp_multicall check nrealcall apply" (is_a nrealcall class_nrep_apply))
	       (let ( (nres (make_instance class_nrep_multiapply
					   :nrep_loc sloc
					   :napp_fun (unsafe_get_field :napp_fun nrealcall)
					   :napp_args (unsafe_get_field :napp_args nrealcall)
					   :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_src_msend)
	       (debug_msg nrealcall "normexp_multicall multicall nrealcall")
	       (assert_msg "normexp_multicall check nrealcall send" (is_a nrealcall class_nrep_msend))
	       (let ( (nres (make_instance class_nrep_multimsend
					   :nrep_loc sloc
					   :nsend_sel (unsafe_get_field :nsend_sel nrealcall)
					   :nsend_recv (unsafe_get_field :nsend_recv nrealcall)
					   :nsend_args (unsafe_get_field :nsend_args nrealcall)
					   :nmulsend_bindings sresbind
					   :nmulsend_body wnbodylet)) )
		 (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 (the_null))
	       )
	     ))))))))
       
(install_method class_src_multicall normal_exp normexp_multicall)

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


;;; create the normal predef (or fail with a msg) 
(defun normal_predef (pred ncx sloc msg)
  (assert_msg "check pred" (is_object pred))
  (assert_msg "check nctxt"  (is_a ncx class_normcontext))
  (let ( (predefmap (unsafe_get_field :nctx_predefmap ncx)) 
	 (brk (mapobject_get predefmap pred)) )
    (if (or (is_integerbox brk) (is_a brk class_symbol))
	(make_instance class_nrep_predef
		       :nrep_loc sloc
		       :nrpredef brk)
      (if (is_string msg) 
	  (progn
	    (debug_msg predefmap "normalpredef predefmap")
	    (debug_msg pred "normalpredef pred")
	    (error_strv sloc "not a predef:" msg)
	    (the_null)
	    )))))


;; 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_normcontext))
  (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 
		(make_instance class_nrep_datastring 
			       :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
			       :nstr_string synamstr
					    ))
	       (syslots (make_multiple discr_multiple
				       (multiple_length (unsafe_get_field :class_fields class_symbol))))
	       (sydata (make_instance class_nrep_datasymbol
				      :ndata_name sym
				      :ndata_discrx (normal_predef class_symbol ncx sloc "class_symbol")
				      :ninst_hash (make_integerbox discr_integer syhash)
				      :ninst_slots syslots
				      :ndsy_namestr synamstr))
	       )
	  (multiple_put_nth syslots (obj_num named_name) synamstrdata)
	  (add_nctx_data ncx sydata)
	  (add_nctx_data ncx synamstrdata)
	  (mapobject_put valmap sym sydata)
	  (mapstring_putstr (unsafe_get_field :nctx_symbmap ncx) synamstr sydata)
	  (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_normcontext))
  (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 
		(make_instance class_nrep_datastring 
			       :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
			       :nstr_string synamstr
					    ))
	       (syslots (make_multiple discr_multiple
				       (multiple_length (unsafe_get_field :class_fields class_keyword))))
	       (sydata (make_instance class_nrep_datakeyword
				      :ndata_name keyw
				      :ndata_discrx (normal_predef class_keyword ncx sloc "class_keyword")
				      :ninst_hash (make_integerbox discr_integer syhash)
				      :ninst_slots syslots
				      :ndsy_namestr synamstr))
	       )
	  (multiple_put_nth syslots (obj_num named_name) synamstrdata)
	  (add_nctx_data ncx sydata)
	  (add_nctx_data ncx synamstrdata)
	  (mapobject_put valmap keyw sydata)
	  (mapstring_putstr (unsafe_get_field :nctx_keywmap ncx) synamstr sydata)
	  (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

(defun normexp_quote (recv env ncx psloc)
  (assert_msg "check quote recv" (is_a recv class_src_quote))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  ;(debug_msg ncx "normexp_quote ncx")
  (debug_msg recv "normexp_quote recv")
  (let ( (sloc   (unsafe_get_field :src_loc recv))
	 (quotedsy (unsafe_get_field :squoted recv)) )
    (assert_msg "check quotedsy" (== (discrim quotedsy) class_symbol))
    (let ( (sdata (normal_symbol_data quotedsy ncx psloc))
	   (curproc (unsafe_get_field :nctx_curproc ncx))
	   )
      (if (is_a curproc class_nrep_routproc)
	  (let ( 
		(nconst (make_instance class_nrep_constant
				       :nrep_loc sloc
				       :nconst_sval quotedsy
				       :nconst_data sdata
				       :nconst_proc curproc
				       )) )
	    (list_append (unsafe_get_field :nrpro_const curproc) sdata)
	    (debug_msg nconst "normexp_quote in routine nconst")
	    (return nconst))
	(progn
	  (debug_msg sdata "normexp_quote in init sdata")
	  (return sdata)
	  )))))
(install_method class_src_quote normal_exp normexp_quote)

;;;;;; normalize a COMMENT
(defun normexp_comment (recv env ncx psloc)
  (assert_msg "check comment recv" (is_a recv class_src_comment))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_comment start recv")
  (let ( (sloc (unsafe_get_field :src_loc recv))
	 (scomm (unsafe_get_field :scomm_str recv))
	 (ncomm (make_instance class_nrep_comment
			       :nrep_loc sloc
			       :ncomm_string scomm
			     ))  
	 (csym (clone_symbol 'comment_)) 
	 (cbind (make_instance class_normlet_binding
			       :letbind_loc sloc
			       :binder csym
			       :letbind_type ctype_void
			       :letbind_expr ncomm))
	 (clocc (make_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_src_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_normcontext))
  ;;(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 (make_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 formal args
(defun fill_normal_formals (sargs nargtuple formsymbmap env ncx sloc)
  (multiple_every
   sargs
   (lambda (fargb :long ix)
     (assert_msg "check fargb" (is_a fargb class_formal_binding))
     (let ( (ftyp (unsafe_get_field :fbind_type fargb)) 
	    (fsymb (unsafe_get_field :binder fargb))
	    (fdataslot (create_data_slots class_formal_binding))
	    (fargdata 
	     (make_instance 
	      class_nrep_datainstance
	      :nrep_loc sloc
	      :ndata_discrx (normal_predef class_formal_binding ncx sloc "class_formal_binding") 
	      :ninst_hash (make_integerbox discr_integer (nonzero_hash))
	      :ninst_slots fdataslot
	      :ninst_objnum (make_integerbox discr_integer ix)
	      ))
	    (fsymbdata (normal_symbol_data fsymb ncx sloc))
	    (ftypdata (normal_predef ftyp ncx sloc "primitive arg type"))
	    )
       (assert_msg "check ftyp" (is_a ftyp class_ctype))
       (add_nctx_data ncx fargdata)
       (fill_data_slot fargdata binder fsymbdata)
       (fill_data_slot fargdata fbind_type ftypdata)
       (multiple_put_nth nargtuple ix fargdata)
       (mapobject_put formsymbmap fsymb fargdata)
       )))
  )

(defun fill_normal_expansion (sexp nexptuple ncx sloc)
  (multiple_every
   sexp
   (lambda (expcomp :long ix)
     (let ( (discrcomp (discrim expcomp)) 
	    (compdata 
	     (cond ( (== discrcomp discr_verbatimstring)
		     (add_nctx_data ncx
				    (make_instance 
				     class_nrep_datastring
				     :ndata_discrx (normal_predef discr_verbatimstring ncx sloc "discr_verbatimstring") 
				     :nstr_string expcomp
				     )))
		   ( (== discrcomp class_symbol)
		     (normal_symbol_data expcomp ncx sloc)
		     )
		   ( :else 
		     (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_src_defprimitive))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (let ( (sloc   (unsafe_get_field :src_loc recv))
	 (sname  (unsafe_get_field :sdef_name recv))
	 (sargs  (unsafe_get_field :sformal_args recv))
	 (stype  (unsafe_get_field :sprim_type recv))
	 (sexp   (unsafe_get_field :sprim_expansion recv))
	 (sprimbind (find_env env sname))
	 ;; we compile to the making of an instance of class_primitive
	 (nslotuple (create_data_slots class_primitive))
	 (nexptuple (make_multiple discr_multiple
				   (multiple_length sexp)))
	 (nargtuple (make_multiple discr_multiple
				   (multiple_length sargs)))
	 (nexpdata (make_instance class_nrep_datatuple
				  :nrep_loc sloc
				  :ndata_name sname
				  :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple")
				  :ntup_comp nexptuple))
	 (nargdata (make_instance class_nrep_datatuple
				  :nrep_loc sloc
				  :ndata_name sname
				  :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple")
				  :ntup_comp nargtuple))
	 (nprimdata (make_instance class_nrep_datainstance
				   :nrep_loc sloc
				   :ndata_name sname
				   :ndata_discrx (normal_predef class_primitive ncx sloc "class_primitive")
				   :ninst_hash (make_integerbox discr_integer (nonzero_hash))
				   :ninst_slots nslotuple)) 
	 (nsymdata (normal_symbol_data sname ncx sloc))
	 ;; map of formal symbol -> data of formal_binding
	 (formsymbmap (make_mapobject discr_mapobjects (+i 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
		     (make_instance 
		      class_nrep_datastring
		      :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
		      :nstr_string (unsafe_get_field :named_name sname))))
    (fill_data_slot nprimdata prim_formals nargdata)
    (fill_data_slot nprimdata prim_expansion nexpdata)
    (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 :pbind_primdata nprimdata))
    (return (the_null))		     ;normalized defprimitive is empty
    ))
(install_method class_src_defprimitive normal_exp normexp_defprimitive)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a DEFCITERATOR
(defun normexp_defciterator (recv env ncx psloc)
  (assert_msg "check defciterator recv" (is_a recv class_src_defciterator))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (let ( 
	(sloc (unsafe_get_field :src_loc recv))
	(sname (unsafe_get_field :sdef_name recv))
	(sciter (let ( (sc (unsafe_get_field :sciterdef_citerator recv)) )
		  (assert_msg "check sciter" (is_a sc class_citerator))
		  sc))
	(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_mapobjects
				     (+i 5 (*i (+i (multiple_length citstafor) (multiple_length citbodfor)) 2))))
	(namstrdata (make_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 (make_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 (make_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 (make_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  (make_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  (make_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)
      )
;;;;;;;
    ;; return the data
    (debug_msg insdata "normexp_defciterator return insdata")
    (return insdata)
    ))
(install_method class_src_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_src_citeration))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (let ( (sloc (unsafe_get_field :src_loc recv))
	 (soper (unsafe_get_field :sciter_oper recv))
	 (sargs (unsafe_get_field :sciter_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))
	 )
    (assert_msg "check soper" (is_a soper class_citerator))
    (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 (!= (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 (make_instance class_normlet_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 (!= 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 (make_instance class_normlet_binding
						 :letbind_loc sloc
						 :binder curvsym
						 :letbind_type curctyp
						 :letbind_expr ()
						 ))
			 (clocc (make_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)
		    )
		(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 (make_instance class_normlet_binding
					   :letbind_loc sloc
					   :binder citstsym
					   :letbind_type ctype_void
					   :letbind_expr ()))
		 (citstocc (make_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_mapobjects (+i 10 nbcitbform)))
		 (citexpander 
		  (lambda (xtup)
		    (debug_msg xtup "normexp_citeration exanding 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
		      (make_instance  class_nrep_citeration
				      :nrep_loc sloc
				      :nciter_citerator soper
				      :nciter_locbindings nlocbindtup
				      :nciter_chunkbefore chkbefore
				      :nciter_body nbody
				      :nciter_bodbindings nbodbindings
				      :nciter_chunkafter chkafter
				      ))
		     (csym (clone_symbol (unsafe_get_field :named_name soper)))
		     (cbind (make_instance class_normlet_binding
					   :letbind_loc sloc
					   :binder csym
					   :letbind_type ctype_void
					   :letbind_expr nciter))
		     (clocc (make_instance class_nrep_locsymocc
					   :nrep_loc sloc
					   :nocc_ctyp ctype_void
					   :nocc_symb csym
					   :nocc_bind cbind))
		     )
		(list_append nbindings cbind)
		(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_src_citeration normal_exp normexp_citeration)







;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a DEFCLASS
(defun normexp_defclass (recv env ncx psloc)
  (assert_msg "check defclass recv" (is_a recv class_src_defclass))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (let ( (sloc   (unsafe_get_field :src_loc recv))
	 (sname  (unsafe_get_field :sdef_name recv))
	 (spredef (unsafe_get_field :sobj_predef recv))
	 (sclabind (unsafe_get_field :sclass_clabind recv))
	 (superbind (unsafe_get_field :sclass_superbind recv))
	 (sfldbinds (unsafe_get_field :sclass_fldbinds recv))
	 )
    (assert_msg "check sclabind" (is_a sclabind class_class_binding))
    (let ( (claobj (unsafe_get_field :cbind_class sclabind)) 
	   (namsymdata (normal_symbol_data sname ncx sloc))
	   (namstrdata
	    (make_instance class_nrep_datastring
			   :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
			   :nstr_string (unsafe_get_field :named_name sname)
			   ))
	   (claslots (make_multiple discr_multiple (obj_len claobj)))
	   (cladata 
	    (make_instance class_nrep_datainstance
			   :nrep_loc sloc
			   :ndata_name sname
			   :ndata_discrx (normal_predef class_class ncx sloc "class_class")
			   :ninst_hash  (make_integerbox discr_integer (obj_hash claobj))
			   :ninst_predef spredef
			   :ninst_slots claslots
			   :ninst_objnum 'OBMAG_OBJECT
			   )) 
	   (ancseq (unsafe_get_field :class_ancestors claobj))
	   (:long nbanc (multiple_length ancseq))
	   (anctup (make_multiple discr_multiple nbanc))
	   (ancdata (make_instance 
		     class_nrep_datatuple
		     :nrep_loc sloc
		     :ndata_name sname
		     :ndata_discrx (normal_predef discr_seqclass ncx sloc "discr_seqclass")
		     :ntup_comp anctup
		     ))
	   (fldseq (unsafe_get_field :class_fields claobj))
	   (:long nbfld (multiple_length fldseq)) ;total number of fields
	   (:long nbownfld (multiple_length sfldbinds)) ;number of own fields
	   (:long nbsupfld (-i nbfld nbownfld))	;number of super(ie inherited) fields
	   (:long ix 0)				;temporary index
	   (fldtup (make_multiple discr_multiple nbfld))
	   (flddata (make_instance 
		     class_nrep_datatuple
		     :nrep_loc sloc
		     :ndata_name sname
		     :ndata_discrx (normal_predef discr_seqfield ncx sloc "discr_seqfield")
		     :ntup_comp fldtup
		     ))
	   ;; the data representing the superclass
	   (superdata (if (is_a superbind class_any_binding) 
			  (normal_exp (unsafe_get_field :binder superbind) env ncx sloc)))
	   )
      (assert_msg "check claobj" (is_a claobj class_class))
      (add_nctx_data ncx cladata)
      (add_nctx_data ncx namstrdata)
      (add_nctx_data ncx ancdata)
      (add_nctx_data ncx flddata)
      (fill_data_slot cladata named_name namstrdata)
      (fill_data_slot cladata class_ancestors ancdata)
      (fill_data_slot cladata class_fields flddata)
      (assert_msg "check sclabind" (is_a sclabind class_class_binding))
      (unsafe_put_fields sclabind :cbind_cladata cladata)
      ;; for each field which is not own, make a data to copy it from the superclass
      (setq ix 0)
      (forever loopsuperfield
	       (if (>=i ix nbsupfld) (exit loopsuperfield))
	       (let ( (supfldata 
		       (make_instance class_nrep_multacc
				      :nrep_loc sloc
				      :naccm_mul
				      (make_instance class_nrep_fieldacc
						     :nrep_loc sloc
						     :naccf_obj superdata
						     :naccf_fld class_fields
						     )
				      :naccm_ix (make_integerbox discr_integer ix)	      
				      )) 
		      )
		 (multiple_put_nth fldtup ix supfldata)
		 )
	       (setq ix (+i ix 1))
	       )
      (setq ix 0)
      ;; for each own field, make an instance of it
      (forever loopownfield
	       (if (>=i ix nbownfld) (exit loopownfield))
	       (let ( (ownfldbind (multiple_nth sfldbinds ix)) )
		 (assert_msg "check ownfldbind" (is_a ownfldbind class_field_binding))
		 (let ( (ownfldsym (unsafe_get_field :binder ownfldbind))
			(ownfld (unsafe_get_field :flbind_field ownfldbind))
			)
		   (assert_msg "check ownfldsym" (is_a ownfldsym class_symbol))
		   (assert_msg "check ownfld" (is_a ownfld class_field))
		   (let ( (ownfldsymdata (normal_symbol_data ownfldsym ncx sloc)) 
			  (ownfldslots (make_multiple discr_multiple (obj_len ownfld)))
			  (ownflstrdata 
			   (make_instance class_nrep_datastring
					  :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") 
					  :nstr_string  (unsafe_get_field :named_name ownfld)
					  ))
			  (ownfldata (make_instance class_nrep_datainstance
						    :nrep_loc sloc
						    :ndata_name ownfldsym
						    :ndata_discrx (normal_predef class_field ncx sloc "class_field")
						    :ninst_hash (make_integerbox discr_integer (obj_hash ownfld))
						    :ninst_objnum (make_integerbox discr_integer (obj_num ownfld))
						    :ninst_slots ownfldslots))
			  )
		     (add_nctx_data ncx ownfldata)
		     (add_nctx_data ncx ownflstrdata)
		     (fill_data_slot ownfldata named_name ownflstrdata)
		     (fill_data_slot ownfldata fld_ownclass cladata)
		     (multiple_put_nth fldtup (+i ix nbsupfld) ownfldata)
		     ;; fill the field binding with its compiled data
		     (unsafe_put_fields ownfldbind :flbind_fdata ownfldata)
		     )))
	       (setq ix (+i ix 1))
	       )
      ;; set the disc_super field to the superclass
      (if superdata (fill_data_slot cladata disc_super superdata))
      ;; compute the class_ancestors into anctup
      (setq ix 0)
      ;; loop on the ancestors of the superclass
      (forever loopancestorsuper
	       (if (>=i ix (-i nbanc 1)) (exit loopancestorsuper))
	       (let ( (supancdata
		       (make_instance class_nrep_multacc
				      :nrep_loc sloc
				      :naccm_mul
				      (make_instance class_nrep_fieldacc
						     :nrep_loc sloc
						     :naccf_obj superdata
						     :naccf_fld class_ancestors)
				      :naccm_ix (make_integerbox discr_integer ix))) )
		 (multiple_put_nth anctup ix supancdata)
		 )
	       (setq ix (+i ix 1))
	       )
      ;; add the superdata as the last component of anctup
      (if superdata (multiple_put_nth anctup (-i nbanc 1) superdata))
      ;; the normalized form of the defclass is the classdata
      cladata
      )))
(install_method class_src_defclass normal_exp normexp_defclass)




;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a DEFINSTANCE
(defun normexp_definstance (recv env ncx psloc)
  (assert_msg "check definstance recv" (is_a recv class_src_definstance))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_definstance recv")
  (let ( (sloc   (unsafe_get_field :src_loc recv))
	 (sname  (unsafe_get_field :sdef_name recv))
	 (spredef (unsafe_get_field :sobj_predef recv))
	 (sdocstr (unsafe_get_field :sobj_docstr recv))
	 (sinstclass (unsafe_get_field :sinst_class recv))
	 (sinstclabnd (unsafe_get_field :sinst_clabind recv))
	 (sinstclasym (if (is_a sinstclabnd class_any_binding) (unsafe_get_field :binder sinstclabnd)))
	 (sinstobjnum (unsafe_get_field :sinst_objnum recv))
	 (sinstfields (unsafe_get_field :sinst_fields recv))
	 (nbindlist (make_list discr_list))
	 (nbindbox (make_box discr_box nbindlist))
	 (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 (the_null))))
    (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 (the_null))))
    (assert_msg "check sinstclass" (is_a sinstclass class_class))
    (assert_msg "check sinstclasym" (is_a sinstclasym class_symbol))
    (let (
	  (slotup (make_multiple discr_multiple
				 (multiple_length (unsafe_get_field :class_fields sinstclass))))
	  (insdata (make_instance class_nrep_datainstance
				  :nrep_loc sloc
				  :ndata_name sname
				  :ndata_discrx icladata
				  :ninst_hash (make_integerbox discr_integer (nonzero_hash))
				  :ninst_predef spredef
				  :ninst_slots slotup
				  :ninst_objnum sinstobjnum
				  )) 
	  )
      (add_nctx_data ncx insdata)
      (put_env env bindins)
      (unsafe_put_fields bindins :ibind_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_src_fieldassign))
	 (let ( (curfld (unsafe_get_field :sfla_field flda))
		(curexp (unsafe_get_field :sfla_expr flda))
		(:long curoff (obj_num curfld))
		)
	   (assert_msg "check curfld" (is_a curfld class_field))
	   (assert_msg "good curfld"
		       (== (multiple_nth (unsafe_get_field :class_fields sinstclass) curoff) 
			   curfld))  
	   (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 ( (nbindlist (box_content nbindbox)))
		  (setq nbindlist (list_append2list nbindlist nbindcur))
		  (box_put nbindbox nbindlist)))))))
;;; put the binding into the data
      (let ( (nbindlist (box_content nbindbox)) 
	     (nbindtup (list_to_multiple nbindlist discr_multiple))
	     )
	(if (>i (multiple_length nbindtup) 0) 
	    (unsafe_put_fields insdata :ndata_locbind nbindtup))
	;; return the data
	(debug_msg insdata "normexp_definstance return insdata")
	insdata
	))))
(install_method class_src_definstance normal_exp normexp_definstance)


;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; normalize a DEFSELECTOR
(defun normexp_defselector (recv env ncx psloc)
  (assert_msg "check defselector recv" (is_a recv class_src_defselector))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp defselector recv")
  (let ( 
	(sloc (unsafe_get_field :src_loc recv))
	(sname (unsafe_get_field :sdef_name recv))
	(spredef (unsafe_get_field :sobj_predef recv))
	(sdocstr (unsafe_get_field :sobj_docstr recv))
	(sinstclass (unsafe_get_field :sinst_class recv))
	(sinstclabnd (unsafe_get_field :sinst_clabind recv))
	(sinstclasym (if (is_a sinstclabnd class_any_binding) (unsafe_get_field :binder sinstclabnd)))
	(sinstobjnum (unsafe_get_field :sinst_objnum recv))
	(sinstfields (unsafe_get_field :sinst_fields recv))
	(nbindlist (make_list discr_list))
	(nbindbox (make_box discr_box nbindlist))
	(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 (the_null))))
    (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 (the_null)))))
    (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 (make_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 (make_instance class_nrep_datainstance
				  :nrep_loc sloc
				  :ndata_name sname
				  :ndata_discrx icladata
				  :ninst_hash (make_integerbox discr_integer (nonzero_hash))
				  :ninst_predef spredef
				  :ninst_slots slotup
				  :ninst_objnum sinstobjnum
				  )) 
	  )
      (add_nctx_data ncx insdata)
      (add_nctx_data ncx namstrdata)
      (unsafe_put_fields bindsel :ibind_data insdata)
      ;; scan the fields initialization
      (multiple_every
       sinstfields
       (lambda (flda :long ix)
	 (assert_msg "check flda" (is_a flda class_src_fieldassign))
	 (let ( (curfld (unsafe_get_field :sfla_field flda))
		(curexp (unsafe_get_field :sfla_expr flda))
		(:long curoff (obj_num curfld))
		)
	   (assert_msg "check curfld" (is_a curfld class_field))
	   (assert_msg "good curfld"
		       (== (multiple_nth (unsafe_get_field :class_fields sinstclass) curoff) 
			   curfld))  
	   (multicall
	    (ncur nbindcur)
	    (normal_exp curexp env ncx sloc)
	    (multiple_put_nth slotup curoff ncur)
	    (if (is_list nbindcur)
		(let ( (nbindlist (box_content nbindbox)))
		  (setq nbindlist (list_append2list nbindlist nbindcur))
		  (box_put nbindbox nbindlist)))))))
;;; put the binding into the data
      (let ( (nbindlist (box_content nbindbox)) 
	     (nbindtup (list_to_multiple nbindlist discr_multiple))
	     )
	(if (>i (multiple_length nbindtup) 0) 
	    (unsafe_put_fields insdata :ndata_locbind nbindtup))
	;; force the name of the selectordata
	(multiple_put_nth slotup (get_int named_name) namstrdata)
	;; return the data
	(debug_msg insdata "normexp_defselector return insdata")
	insdata
	))))
(install_method class_src_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_normcontext))
  (let ( (csymvalexp (clone_symbol '_valuexporter_))
	 (nsysdat (make_instance class_nrep_predef
				 :nrep_loc psloc
				 :nrpredef 'INITIAL_SYSTEM_DATA))
	 (cbind (make_instance class_normlet_binding
			       :letbind_loc psloc
			       :binder csymvalexp
			       :letbind_type ctype_value
			       :letbind_expr (make_instance class_nrep_unsafe_get_field
							    :nrep_loc psloc
							    :nuget_obj nsysdat
							    :nuget_field sysdata_value_exporter)))
	 (locsym (make_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_normcontext))
  (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 (make_instance class_src_current_module_environment_container
				    :src_loc 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 (
	   (cbind (make_instance class_normlet_binding
				 :letbind_loc psloc
				 :binder csymexpo
				 :letbind_type ctype_void
				 :letbind_expr (make_instance class_nrep_apply
							      :nrep_loc psloc
							      :napp_fun nvaluexp
							      :napp_args (make_tuple3 discr_multiple symdata nexp ncurenvbox))))
	   (syocc (make_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_src_export_values))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_export_values recv")
  (let ( 
	(sloc (unsafe_get_field :src_loc recv))
	(sxnames (unsafe_get_field :sexport_names recv))
	(bindslist (make_list discr_list))
	(nvaluexporter (normal_value_exporter env ncx sloc bindslist))
	(nilnrep (make_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_src_export_values normal_exp normexp_export_values)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; normalize an export_class
(defun normexp_export_class (recv env ncx psloc)
  (assert_msg "check export_class recv" (is_a recv class_src_export_class))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp export_class recv")
  (let ( 
	(sloc (unsafe_get_field :src_loc recv))
	(sxnames (unsafe_get_field :sexport_names recv))
	(bindslist (make_list discr_list))
	(nvaluexporter (normal_value_exporter env ncx sloc bindslist))
	(nilnrep (make_instance class_nrep_nil
				:nrep_loc sloc))
	)
    (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 :cbind_cladata 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)) 
		    )
	       (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 :flbind_fdata fldbind))
				 (nfld (normal_exported_value fldsym fldata nvaluexporter env ncx sloc bindslist))
				 )
			    (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_src_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_normcontext))
  (debug_msg psloc "normal_macro_exporter start psloc")
  (let ( (csymvalexp (clone_symbol '_macroxporter_))
	 (nsysdat (make_instance class_nrep_predef
				 :nrep_loc psloc
				 :nrpredef 'INITIAL_SYSTEM_DATA))
	 (cbind (make_instance class_normlet_binding
			       :letbind_loc psloc
			       :binder csymvalexp
			       :letbind_type ctype_value
			       :letbind_expr (make_instance class_nrep_unsafe_get_field
							    :nrep_loc psloc
							    :nuget_obj nsysdat
							    :nuget_field sysdata_macro_exporter)))
	 (locsym (make_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)
    ))

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

(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_normcontext))
  (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 (make_instance class_src_current_module_environment_container
				  :src_loc 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 (
	   (cbind (make_instance class_normlet_binding
				 :letbind_loc psloc
				 :binder csymexpo
				 :letbind_type ctype_void
				 :letbind_expr (make_instance class_nrep_apply
							      :nrep_loc psloc
							      :napp_fun nmacroxp
							      :napp_args (make_tuple3 discr_multiple symdata nexp ncurenvbox))))
	   (syocc (make_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_src_export_macro))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp export_macro recv")
  (let ( 
	(sloc (unsafe_get_field :src_loc 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 (make_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_src_export_macro normal_exp normexp_export_macro)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; 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_src_current_module_environment_container))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_current_module_environment_container recv")
  (let ( 
	(sloc (unsafe_get_field :src_loc 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 (make_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_src_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_src_parent_module_environment))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_parent_module_environment  recv")
  (let ( 
	(sloc (unsafe_get_field :src_loc recv))
	(curproc (unsafe_get_field :nctx_curproc ncx))
	(qdatpar (unsafe_get_field :nctx_qdatparmodenv ncx))
	(nquasi (make_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_src_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_src_update_current_module_environment_container))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_update_current_module_environment_container recv")
  (let ( 
	(sloc (unsafe_get_field :src_loc 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_modulcontext) (unsafe_get_field :mocx_modulename modctx)))
	)
    (if (!= curproc iniproc)
	(progn
	  (error_plain sloc "(UPDATE_CURRENT_MODULE_ENVIRONMENT_CONTAINER) not at toplevel")
	  (return)))
    (let ( (nup (make_instance class_nrep_update_current_module_environment_container
			       ;; :ncumeb_expr filled later
			       :nrep_loc sloc
			       :ncumeb_comment scomm
			       )) 
	   (csym (clone_symbol 'updatcurmodenvbox_))
	   (cbind (make_instance 
		   class_normlet_binding
		   :letbind_loc sloc
		   :binder csym
		   :letbind_type ctype_void
		   ;; ctype_void because the sideffect is in nup
		   :letbind_expr nup))
	   (clocc (make_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 (make_instance class_src_current_module_environment_container
				      :src_loc sloc
				      :cmec_comment (strbuf2string discr_string csbuf)))
	   (sgetcurenvbox
	    (make_instance 
	     class_src_or
	     :src_loc psloc
	     :sor_disj 
	     (make_tuple2
	      discr_multiple
	      scurenvbox
	      (make_instance 
	       class_src_apply
	       :src_loc psloc
	       :sapp_fun (make_instance
			  class_src_unsafe_get_field
			  :src_loc psloc
			  :suget_obj (make_instance
				      class_src_fetch_predefined
				      :src_loc psloc
				      :sfepd_predef 'initial_system_data
				      )
			  :suget_field sysdata_cont_fresh_env
			  )
	       :sapp_args (make_tuple2 discr_multiple
				       (make_instance class_src_parent_module_environment
						      :src_loc 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_src_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_src_fetch_predefined))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_fetch_predefined recv")
  (let ( 
	(sloc (unsafe_get_field :src_loc 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 (make_instance class_nrep_predef
				:nrep_loc sloc
				:nrpredef spred
				))
	   )
      (debug_msg npre "normexp_fetch_predefined result npre")
      (return npre)
      )))
(install_method class_src_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_src_store_predefined))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_store_predefined recv")
  (let ( 
	(sloc (unsafe_get_field :src_loc 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 (make_instance class_nrep_store_predefined
				 :nrep_loc sloc
				 :nstpd_predef spred
				 :nstpd_value nval))
	   (cbind (make_instance class_normlet_binding
				 :binder csym
				 :letbind_type ctype_value
				 :letbind_expr nfpre))
	   (syocc (make_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_src_store_predefined normal_exp normexp_store_predefined)

(assert_msg "check class_symbol" (is_a class_symbol class_class))
(debug_msg class_symbol "end of warmelt-normal our Class_Symbol")
(debug_msg (fetch_predefined CLASS_SYMBOL) "end of warmelt-normal predefined Class_Symbol")
(debug_msg install_initial_macro "at end of warmelt-normal Install_Initial_Macro")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; eof warmelt-normal.bysl