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

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

    This file is part of GCC.

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

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

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

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

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


;;; class for the context of normalization of patterns
(defclass class_pattern_context
  :super class_root
  :fields (pctn_normctxt		;the class_normalization_context
	   pctn_src			;the source match expressioon
	   pctn_env			;the current environment
	   ;; mapping symbols to patternvars
	   pctn_mapatvar		;objmap of patternvars
	   ;; mapping constant objects to their patternconsts
	   pctn_mapatcst		;objmap of patternconst
	   ;; mapping or source patterns to their map of symbols to patternvars
	   pctn_mapor
	   ;; binding list for input arguments in matcher
	   pctn_bindlist		;binding list 
	   ;; mapping matched stuff with list of normtesters
	   pctn_stuffmap
	   ;; mapping pattern variable symbols to local occurrences 
	   pctn_pvarlocmap
	   ;; list of tests
	   pctn_tests
	   ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; selector to scan a pattern
;;; invoked with :
;;; * the source pattern as reciever
;;; * a parent source location
;;; * a ctype
;;; * a normpatcontext
(defselector scan_pattern class_selector
  )



;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; catch-all for scanning any reciever (by failing)
(defun scanpat_anyrecv (recv psloc ctyp pcn)
  (debug_msg recv "scanpat_anypattern recv")
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (let ( (myclass (discrim recv))
	 (myclassname (get_field :named_name myclass)) )
    (error_strv psloc 
		"unimplemented scan_pattern for any " myclassname)
    (assert_msg "catchall scan_pattern unimplemented for any reciever" ())
    ))
(install_method discr_any_receiver scan_pattern scanpat_anyrecv)


;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; catch-all for scanning any pattern (by failing)
(defun scanpat_anypattern (recv psloc ctyp pcn)
  (debug_msg recv "scanpat_anypattern recv")
  (assert_msg "check recv" (is_a recv class_source_pattern))
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (let ( (myclass (discrim recv))
	 (myclassname (get_field :named_name myclass)) )
    (debug_msg myclass "scanpat_anypattern myclass [discrim of recv]")
    (error_strv psloc 
		"unimplemented scan_pattern for pattern " myclassname)
    (assert_msg "catchall scan_pattern unimplemented for pattern" ())
    ))
(install_method class_source_pattern scan_pattern scanpat_anypattern)

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;; scanning pattern variable
(defun scanpat_srcpatvar (recv psloc ctyp pcn)
  (debug_msg recv "scanpat_srcpatvar recv")
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (assert_msg "check recv" (is_a recv class_source_pattern_variable))
  (let ( (sloc (unsafe_get_field :loca_location recv))
	 (svar (unsafe_get_field :spat_var recv))
	 (mapvar (unsafe_get_field :pctn_mapatvar pcn))
	 (mvar (mapobject_get mapvar svar))
	 )
    (cond ( (null mvar)
	    (mapobject_put mapvar svar recv)
	    (debug_msg svar "scanpat_srcpatvar return new svar")
	    (return)
	    )
	  (:else
	   (debug_msg mvar "scanpat_srcpatvar return found mvar")
	   (return)
	   ))
    ))
(install_method class_source_pattern_variable scan_pattern scanpat_srcpatvar)

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;; scanning pattern joker
(defun scanpat_srcpatjoker (recv psloc ctyp pcn)
  (debug_msg recv "scanpat_srcpatjoker recv")
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (assert_msg "check recv" (is_a recv class_source_pattern_joker_variable))
  ;; just return
  (return)
  )
(install_method class_source_pattern_joker_variable scan_pattern scanpat_srcpatjoker)


;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;; scanning an as pattern
(defun scanpat_srcpatas (recv psloc ctyp pcn)
  (debug_msg recv "scanpat_srcpatas recv")
  (debug_msg ctyp "scanpat_srcpatas ctyp")
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (assert_msg "check recv" (is_a recv class_source_pattern_as))
  (let ( (sloc (unsafe_get_field :loca_location recv))
	 (asvarpat (unsafe_get_field :aspat_varpat recv))
	 (asvar (get_field :spat_var asvarpat))
	 (asubp (unsafe_get_field :aspat_subpat recv))
	 (mapvar (unsafe_get_field :pctn_mapatvar pcn))
	 (mvar (mapobject_get mapvar asvar))
	 )
    (debug_msg asvar "scanpat_srcpatas asvar")
    (assert_msg "check asvar" (is_a asvar class_symbol))
    (if (null mvar)
	(progn
	  (mapobject_put mapvar asvar asvarpat)
	  (debug_msg asvar "scanpat_srcpatas got new asvar")
	  ))
    (scan_pattern asubp sloc ctyp pcn)
    ))
(install_method class_source_pattern_as scan_pattern scanpat_srcpatas)


;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;; scanning a pattern constant
(defun scanpat_srcpatconst (recv psloc ctyp pcn)
  (debug_msg recv "scanpat_srcpatconst recv")
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (assert_msg "check recv" (is_a recv class_source_pattern_constant))
  (let ( (sconst (unsafe_get_field :spat_constx recv))
	 (sloc (unsafe_get_field :loca_location recv))
	 (ncx (unsafe_get_field :pctn_normctxt pcn))
	 (mapcst (unsafe_get_field :pctn_mapatcst pcn))
	 (mcst (if (is_object sconst) (mapobject_get mapcst sconst)))
	 (ncst mcst)
	 (bindlist (unsafe_get_field :pctn_bindlist pcn))
	 (env (unsafe_get_field :pctn_env pcn))
	 )
    (assert_msg "check bindlist" (is_list bindlist))
    (cond 
     ( (not (is_object sconst))
       (debug_msg sconst "scanpat_srcpatconst nonobj literal const")
	(setq ncst sconst)
       )
     ( (null mcst)
       (multicall
	(nconst nbindconst)
	(normal_exp sconst env ncx sloc)
	(debug_msg nconst "scanpat_srcpatconst nconst")
	(mapobject_put mapcst sconst nconst)
	(if nbindconst (list_append2list bindlist nbindconst))
	(setq ncst nconst)
	))
     (:else
      (debug_msg mcst "scanpat_srcpatconst got mcst")
      ))
    (debug_msg ncst "scanpat_srcpatconst ncst")
    (let ( (rectyp (get_ctype ncst env)) )
      (debug_msg rectyp "scanpat_srcpatconst rectyp")
      (assert_msg "check rectyp" (is_a rectyp class_ctype))
      (cond ((!= rectyp ctyp)
	     (error_strv sloc "invalid ctype in constant pattern - expecting"
			 (unsafe_get_field :named_name rectyp))
	     (warning_strv sloc "got ctype"
			   (unsafe_get_field :named_name ctyp))
	     ))
      )))
(install_method class_source_pattern_constant scan_pattern scanpat_srcpatconst)

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;; scanning a pattern object or instance
(defun scanpat_srcpatobject (recv psloc ctyp pcn)
  (debug_msg recv "scanpat_srcpatobject recv")
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (assert_msg "check recv" (is_a recv class_source_pattern_object))
  (let ( (sloc (unsafe_get_field :loca_location recv))
	 (scla (unsafe_get_field :spat_class recv))
	 (sfields (unsafe_get_field :spat_fields recv))
	 )
    (assert_msg "check scla" (is_a scla class_class))
    (assert_msg "check sfields" (is_multiple sfields))
    (foreach_in_multiple
     (sfields)
     (fldpa :long ix)
     (assert_msg "check fldp" (is_a fldpa class_source_field_pattern))
     (let ( (fld (let ( ( f (get_field :spaf_field fldpa)) )
		   (assert_msg "check fld" (is_a f class_field))
		   f))
	    (flcla (get_field :fld_ownclass fld))
	    (fpat (unsafe_get_field :spaf_pattern fldpa))
	    )
       (cond ( (not (subclass_or_eq scla flcla))
	       (error_strv sloc "bad field in object pattern"
			   (unsafe_get_field :named_name fld))
	       (inform_strv sloc "class in pattern is" (get_field :named_name scla))
	       (inform_strv sloc "class of field is" (get_field :named_name flcla))
	       (return)))
       (scan_pattern fpat sloc ctype_value pcn)
       )
     )
    (debug_msg recv "scanpat_srcpatobject end recv")
    )
  )
(install_method class_source_pattern_object scan_pattern scanpat_srcpatobject)


;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;; scanning a composite pattern 
(defun scanpat_srcpatcomposite (recv psloc ctyp pcn)
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (debug_msg recv "scanpat_srcpatcomposite start recv")
  (debug_msg ctyp "scanpat_srcpatcomposite start ctyp")
  (assert_msg "check ctyp" (is_a ctyp class_ctype))
  (assert_msg "check recv" (is_a recv class_source_pattern_composite))
  (let ( (sloc (unsafe_get_field :loca_location recv))
	 (soper (let ((sop (unsafe_get_field :spac_operator recv)))
		  (debug_msg sop "scanpat_srcpatcomposite soper")
		  (assert_msg "check soper" (is_a sop class_any_matcher))
		  sop))
	 (sins (unsafe_get_field :spac_inargs recv)) 
	 (souts (unsafe_get_field :spac_outargs recv)) 
	 (matmb (let ( (mb (unsafe_get_field :amatch_matchbind soper)) )
		  (debug_msg mb "scanpat_srcpatcomposite matmb")
		  (assert_msg "check matmb" (is_a mb class_formal_binding))
		  mb))
	 (matin (unsafe_get_field :amatch_in soper))
	 (matout (unsafe_get_field :amatch_out soper))
	 (opnam (unsafe_get_field :named_name soper))
	 (matctyp (unsafe_get_field :fbind_type matmb))
	 (env (unsafe_get_field :pctn_env pcn))
	 (ncx (unsafe_get_field :pctn_normctxt pcn))
	 (bindlist (unsafe_get_field :pctn_bindlist pcn))
	 )
    (assert_msg "check matctyp" (is_a matctyp class_ctype))
    (debug_msg matout "scanpat_srcpatcomposite matout")
    (cond ((!= ctyp matctyp)
	   (error_strv sloc "invalid ctype in composite pattern - expecting"
		       (unsafe_get_field :named_name matctyp))
	   (warning_strv sloc "got ctype"
			 (unsafe_get_field :named_name ctyp))
	   (debug_msg ctyp "scanpat_srcpatcomposite mismatched ctyp")
	   (debug_msg matctyp "scanpat_srcpatcomposite mismatched matctyp")
	   (debug_msg recv "scanpat_srcpatcomposite mismatched recv")
	   ;;
	   (return)))
    (multicall 
     (nins bindins)
     (normalize_tuple sins env ncx sloc)
     (debug_msg nins "scanpat_srcpatcomposite nins")
     (if bindins (list_append2list bindlist bindins))
     (debug_msg souts "scanpat_srcpatcomposite souts")
     (debug_msg matout "scanpat_srcpatcomposite matout")
     (foreach_in_multiple
      (souts)
      (pout :long ix)
      (debug_msg pout "scanpat_srcpatcomposite before scan_pattern pout")
      (let ( (curobind (multiple_nth matout ix)) 
	     (curctype (get_field :fbind_type curobind))
	     )
	(debug_msg curobind "scanpat_srcpatcomposite curobind")
	(debug_msg curctype "scanpat_srcpatcomposite curctype")
	(assert_msg "check curctype" (is_a curctype class_ctype))
	(scan_pattern pout sloc curctype pcn)
	(debug_msg pout "scanpat_srcpatcomposite after scan_pattern pout")
	))
     (debug_msg recv "scanpat_srcpatcomposite end recv")
     )))
(install_method class_source_pattern_composite scan_pattern scanpat_srcpatcomposite)


;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;; scanning or pattern
(defun scanpat_srcpator (recv psloc ctyp pcn)
  (debug_msg recv "scanpat_srcpator recv")
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (assert_msg "check recv" (is_a recv class_source_pattern_or))
  (debug_msg pcn "scanpat_srcpator pcn start")
  (let ( (sloc (unsafe_get_field :loca_location recv))
	 (sdisj (unsafe_get_field :orpat_disj recv))
	 (pvarmap (unsafe_get_field :pctn_mapatvar pcn))
	 (:long cntpvarmap (mapobject_count pvarmap))
	 (inipvarmap 
	  (let ( 
		(inimap (make_mapobject discr_map_objects
					(+i 3 (/i (*i cntpvarmap 5) 4))))
		)
	    (foreach_in_mapobject 
	     (pvarmap)
	     (cursym curpatvar)
	     (mapobject_put inimap cursym curpatvar))
	    inimap))
	 )
    (debug_msg sdisj "scanpat_srcpator sdisj")
    (assert_msg "check sdisj" (is_multiple sdisj))
    (foreach_in_multiple
     (sdisj)
     (dis :long ix)
     (debug_msg dis "scanpat_srcpator dis")
     (scan_pattern dis sloc ctyp pcn)
     )
    (let ( (:long incrpvarmap (-i (mapobject_count pvarmap)
				  cntpvarmap))
	   (pmapor (get_field :pctn_mapor pcn))
	   (orvarmap (make_mapobject discr_map_objects
				     (+i 3 (/i (*i incrpvarmap 5) 4))))
	   )
      (assert_msg "check pmapor" (is_mapobject pmapor))
      ;; scan the updated pvarmap for new entries w.r.t. inipvarmap
      (foreach_in_mapobject 
       (pvarmap)
       (cursym curpatvar)
       (assert_msg "check cursym" (is_a cursym class_symbol))
       (assert_msg "check curpatvar" 
		   (is_a curpatvar class_source_pattern_variable))
       (assert_msg "good curpatvar"
		   (== (get_field :spat_var curpatvar) cursym))
       (if (null (mapobject_get inipvarmap cursym))
	   (mapobject_put orvarmap cursym curpatvar))
       )
      (debug_msg orvarmap "scanpat_srcpator orvarmap")
      (mapobject_put pmapor recv orvarmap)
      )
    (debug_msg pcn "scanpat_srcpator pcn end")
    (debug_msg recv "scanpat_srcpator recv end")
    ))
(install_method class_source_pattern_or scan_pattern scanpat_srcpator)




;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;; scanning and pattern
(defun scanpat_srcpatand (recv psloc ctyp pcn)
  (debug_msg recv "scanpat_srcpatand recv")
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (assert_msg "check recv" (is_a recv class_source_pattern_and))
  (let ( (sloc (unsafe_get_field :loca_location recv))
	 (sconj (unsafe_get_field :andpat_conj recv))
	 )
    (assert_msg "check sconj" (is_multiple sconj))
    (foreach_in_multiple
     (sconj)
     (dis :long ix)
     (scan_pattern dis sloc ctyp pcn)
     )
    (debug_msg recv "scanpat_srcpatand end recv")
    ))
(install_method class_source_pattern_and scan_pattern scanpat_srcpatand)

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

;;; selector to normalize a pattern
;;; reciever is the pattern to normalize
;;; arguments are
;;; the normal matched stuff
;;; the closure (if any) to handle the newly created stuff -e.g. tester
;;; the pattern context


(defselector normal_pattern class_selector)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass class_normal_or_variable
  :super class_root
  :fields (
	   norvar_patvar		
	   norvar_nrepor
	   norvar_locsym 
	   )
  :doc #{The $CLASS_NORMAL_OR_VARIABLE is an internal class for
  normalization of variables under an $OR pattern. Field
  $NORVAR_PATVAR gives the associated pattern variable, field
  $NORVAR_NREPOR gives the normalized or pattern, and field
  $NORVAR_LOCSYM gives the local symbol occurrence if any.}#
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; all the testers share a common superclass
(defclass class_normtester_any 
  :super class_nrep_expression	;inherit fields: nrep_loc
  :fields (ntest_matched       	;normal matched thing
	   ntest_then		;tester to run if successful
	   ntest_else		;tester to run if failed
	   ntest_normatch	;the containing normalized match
	   ;; a list of class_nrep_locsymocc 
	   ntest_locclist	;the local occurence list inside the test
	   ;; list of tests going into this one
	   ntest_comefrom
	   ))



;; final successful tester (always succeed) just evaluate the expression
(defclass class_normtester_success
  :super class_normtester_any
  :fields (ntsuccess_do		;single expression (usually a normlet)
	   ))
 
;; quasi-tester used at end of or branches to clear a list of variables
(defclass class_normtester_orclear
  :super class_normtester_any
  :fields (ntorclear_locsym    ;tuple of symbol occurrences to clear
	   ))

;; all real tests share this superclass
(defclass class_normtester_anytester
  :super class_normtester_any
  :fields (
	   ))

;;; the tester wrapping or.  Needed to share the same ntest_then
;;; between disjuncts
(defclass class_normtester_disjunction
  :super class_normtester_anytester
  :fields (ntdisjuncts			;the tuple of disjunct tests
	   )
)
;; test for same (ie identical) stuff
(defclass class_normtester_same
  :super class_normtester_anytester
  :fields (ntsame_identical		;checked normal stuff
	   ))

;; test for matcher
(defclass class_normtester_matcher
    :super class_normtester_anytester
    :fields (
	     ntmatch_matcher		;the matcher
	     ntmatch_matndata		;the marcher's normal data
	     ;; both inargs & outlocs are normalized
	     ntmatch_inargs		;its input arguments tuple
	     ntmatch_outlocs		;its output locals
	     ))


;; test for instance
(defclass class_normtester_instance
    :super class_normtester_anytester
    :fields (ntinst_class		;the class 
	     ;; a tuple similar to the class's fields
	     ntinst_fieldlocs		;the tuple of field locals or nil
	     ))

;;;;;;;;;;;;;;;;
(defclass class_nrep_match
  :super class_nrep_typed_expression
  :fields (nmatch_tests			;sequence of tests
	   nmatch_stuffmap		;mapping matched stuff with
					;list or normal tests
	   nmatch_matched		;the normal matched stuff
	   ))

;;;;;; utility function to register a new normtester
(defun register_new_normtester (ntest pcn)
  (debug_msg ntest "register_new_normtester ntest")
  (debug_msg pcn "register_new_normtester pcn")
  (assert_msg "check ntest" (is_a ntest class_normtester_any))
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (let ( (nmatched (unsafe_get_field :ntest_matched ntest))
	 (stuffmap (unsafe_get_field :pctn_stuffmap pcn))
	 )
    (assert_msg "check nmatched" (is_object nmatched))
    (assert_msg "check stuffmap" (is_mapobject stuffmap))
    (let (
	  (ntlist
	   (let ( (ntl (mapobject_get stuffmap nmatched)) )
	     (if (is_list ntl) 
		 ntl
	       (let ( (newntl (make_list discr_list)) )
		 (mapobject_put stuffmap nmatched newntl)
		 newntl)
	       )))
	  )
      (assert_msg "check ntlist" (is_list ntlist))
      (list_append ntlist ntest)
      (debug_msg stuffmap "register_new_normtester updated stuffmap")
      (return)
      )))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;; utility to set the then of a last test; also handle the case of
;; disjunctions by propagating into them
(defun put_tester_then (curtester thentester)
  (debug_msg curtester "put_tester_then curtester")
  (debug_msg thentester "put_tester_then thentester")
  (assert_msg "check curtester" (is_a curtester class_normtester_any))
  (assert_msg "check thentester" (is_a thentester class_normtester_any))
  (assert_msg "check curtester has no then" 
	     (null (unsafe_get_field :ntest_then curtester)))
  (let ( (thencome (unsafe_get_field :ntest_comefrom thentester)) )
    (assert_msg "check thencome" (is_list thencome))
    (list_append thencome curtester))
  (assert_msg "check curtester not a normtester success"
	      (is_not_a curtester class_normtester_success))
  (unsafe_put_fields curtester :ntest_then thentester)
  ;;; propagate into disjunctions
  (if (is_a curtester class_normtester_disjunction)
      (let ( (curdisjtuple (unsafe_get_field :ntdisjuncts curtester)) )
	(debug_msg curdisjtuple "put_tester_then curdisjtuple")
	(foreach_in_multiple 
	 (curdisjtuple)
	 (curdisj :long disjix)
	 (debug_msg curdisj "put_tester_then curdisj")
	 (let ( (curcont (instance class_container :container_value curdisj)) )
	 (debug_msg curcont "put_tester_then curcont start")
	 (set_new_tester_last_then thentester curcont)
	 (debug_msg curcont "put_tester_then curcont done")
	 ))
      ))
  (debug_msg curtester "put_tester_then curtester done")
)

;; utility to set the newtester to the last of a ntest_then linked list
(defun set_new_tester_last_then (newtester testercont)
  (debug_msg newtester "set_new_tester_last_then newtester")
  (debug_msg testercont "set_new_tester_last_then testercont")
  (shortbacktrace_dbg "set_new_tester_last_then start" 15)
  (assert_msg "check newtester" (is_a newtester class_normtester_any))
  (assert_msg "check testercont" (is_a testercont class_container))
  (let ( (curtester (get_field :container_value testercont)) )
    (forever 
     lastesterloop
     (debug_msg curtester "set_new_tester_last_then loop curtester")
     ;; indeed a safe get_field to handle the nil case!
     (let ( (nextester (get_field :ntest_then curtester)) )
       (if (is_a nextester class_normtester_any)
	   (setq curtester nextester)
	 (exit lastesterloop))))
    (debug_msg curtester "set_new_tester_last_then final curtester")
    (assert_msg "check curtester set_new_tester_last_then" curtester)
    (put_fields testercont :container_value curtester)
    (put_tester_then curtester newtester)
    (debug_msg testercont "set_new_tester_last_then end testercont")
    ))


;; recursive utility to set a newtester as all the unset else branches
;; of a given partester return the list of updated testers, ie the
;; updatlist - which should be null initially
(defun set_new_tester_all_elses (newtester partester updatlist)
  (debug_msg newtester "set_new_tester_all_elses newtester")
  (debug_msg partester "set_new_tester_all_elses partester")
  (shortbacktrace_dbg "set_new_tester_all_elses start" 15)
  (assert_msg "check newtester" (is_a newtester class_normtester_any))
  (assert_msg "check partester" (is_a partester class_normtester_anytester))
  (if (null updatlist) 
      (setq updatlist (make_list discr_list)))
  (assert_msg "check updatlist" (is_list updatlist))
  (forever
   allelseloop
   (debug_msg partester "set_new_tester_all_elses allelseloop partester")
   (cond
    ((null partester) 
     (exit allelseloop))
    ((is_a partester class_normtester_anytester)
     (let ( (eltest (unsafe_get_field :ntest_else partester)) 
	    (thtest (unsafe_get_field :ntest_then partester))
	    )
       (cond
	((null eltest)
	 (put_fields partester :ntest_else newtester)
	 (debug_msg partester "set_new_tester_all_elses updated partester")
	 (list_append updatlist partester)
	 )
	(:else
	 (foreach_in_list
	  (updatlist)
	  (curpair curtest)
	  (if (== curtest partester) 
	      (exit allelseloop))
	  (if (== curtest newtester)
	      (exit allelseloop))
	  )
	 (setq partester eltest))
	)
       (cond ( (is_a thtest class_normtester_anytester)
	 (foreach_in_list
	  (updatlist)
	  (curpair curtest)
	  (if (== curtest thtest) 
	      (exit allelseloop))
	  (if (== curtest newtester)
	      (exit allelseloop))
	  )
	 (debug_msg thtest "set_new_tester_all_elses before recursion")
	 (set_new_tester_all_elses newtester thtest updatlist)
	 (debug_msg thtest "set_new_tester_all_elses after recursion")
	 )))
     )
    (:else
     (exit allelseloop)))
   ) ;;;; end forever allelseloop
  (debug_msg updatlist "set_new_tester_all_elses return updatlist")
  (return updatlist)
  )
  


;;; expansion of tuples in cmatcher should be done in warmelt-genobj

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; catch-all for normpat any reciever (by failing)
(defun normpat_anyrecv (recv nmatch hdler pcn)
  (debug_msg recv "normpat_anyrecv recv")
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (let ( (myclass (discrim recv))
	 (myclassname (get_field :named_name myclass)) 
	 (psloc (get_field :loca_location (get_field :pctn_src pcn)))
	 )
    (error_strv psloc 
		"unimplemented normal_pattern for any " myclassname)
    (assert_msg "catchall normal_pattern unimplemented" ())
    ))
(install_method discr_any_receiver normal_pattern normpat_anyrecv)

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; catch-all for normpat any pattern (by failing)
(defun normpat_anypat (recv nmatch hdler  pcn)
  (debug_msg recv "normpat_anyrecv recv")
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (assert_msg "check recv" (is_a recv class_source_pattern))
  (let ( (myclass (discrim recv))
	 (myclassname (get_field :named_name myclass)) 
	 (psloc (get_field :loca_location (get_field :pctn_src pcn)))
	 )
    (error_strv psloc 
		"unimplemented NORMAL_PATTERN for pattern of " myclassname)
    (assert_msg "catchall normal_pattern unimplemented on pattern" ())
    ))
(install_method class_source_pattern normal_pattern normpat_anypat)


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

;;; internal function when normalizing a variable pattern to generate
;;; or reuse a test
(defun normvarpat_genreusetest (sloc nmatch lococc testlist tstuff hdler pcn)
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (assert_msg "check lococc" (is_a lococc class_nrep_locsymocc))
  (let (
	(tester ())
	(curhdler hdler)
	)
    (forever 
     loopstuff
     (debug_msg tstuff "normvarpat_genreusetest tstuff")
     (cond 
      ( (== (get_field :ntsame_identical tstuff) lococc)
	(setq tester tstuff)
	(exit loopstuff)
	)
      ( (is_a tstuff class_normtester_any)
	(setq tstuff (get_field :ntest_else tstuff))
	(setq curhdler 
	      (lambda (tester)
		(shortbacktrace_dbg "normvarpat_genreusetest lambda curhdler" 15)
		(put_fields tstuff :ntest_else tester)
		(debug_msg tstuff "normvarpat_genreusetest lambda curhdler updatelse of tstuff")
		(list_append (get_field :ntest_comefrom tester) tstuff)
		))
	)
      (:else
       (let ( (newtester (instance class_normtester_same
				   :nrep_loc sloc
				   :ntest_matched nmatch
				   :ntest_then ()
				   :ntest_else ()
				   :ntest_locclist ()
				   :ntest_comefrom (make_list discr_list)
				   :ntsame_identical lococc))
	      )
	 (shortbacktrace_dbg "normvarpat_genreusetest making same newtester" 15)
	 (register_new_normtester newtester pcn)
	 (debug_msg newtester "normvarpat_genreusetest newtester same")
	 (setq tester newtester)
	 (list_append testlist newtester)
	 (curhdler newtester)
	 (exit loopstuff)
	 )
       )
      )
     )
    )
  )

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; normalize variable pattern
(defun normpat_variablepat (recv nmatch hdler pcn)
  (debug_msg recv "normpat_variablepat recv")
  (debug_msg nmatch "normpat_variablepat nmatch")
  (assert_msg "check recv" (is_a recv class_source_pattern_variable))
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (shortbacktrace_dbg "normpat_variablepat begin" 15) 
  (let ( (stuffmap (get_field :pctn_stuffmap pcn))
	 (pvarmap (get_field :pctn_pvarlocmap pcn)) 
	 (psloc (get_field :loca_location (get_field :pctn_src pcn)))
	 (sloc (get_field :loca_location recv))
	 (patvar (get_field :spat_var recv))
	 (tstuff (mapobject_get stuffmap nmatch))
	 (lococc (mapobject_get pvarmap patvar))
	 (env (get_field :pctn_env pcn))
	 (ncx (get_field :pctn_normctxt pcn))
	 (testlist (get_field :pctn_tests pcn))
	 )
    (debug_msg tstuff "normpat_variablepat tstuff")
    (debug_msg lococc "normpat_variablepat lococc")
    (debug_msg patvar "normpat_variablepat patvar")
    (compile_warning "we need to generate the clear of all or-variables")
    (cond 
     ( (is_a lococc class_nrep_locsymocc)
       ;; patvar already bound, generate or reuse a same test
       (debug_msg lococc "normpat_variablepat alreadybound lococc")
       (normvarpat_genreusetest sloc nmatch lococc testlist tstuff hdler pcn)
       )
     ;; process specially or variables
     ((is_a lococc class_normal_or_variable)
      (debug_msg lococc "normpat_variablepat lococc orvariable")
      (compile_warning "normpat_variablepat unhandled orvariable")
      (let ( (realococc (unsafe_get_field :norvar_locsym lococc)) 
	     (npatvar (unsafe_get_field :norvar_patvar lococc))
	     (patsym (get_field :spat_var npatvar))
	     )
	(debug_msg npatvar "normpat_variablepat orvariable npatvar")
	(assert_msg "check patsym == patvar" (== patsym patvar))
	(debug_msg realococc "normpat_variablepat orvariable realococc")
	(cond ( (null realococc)
		;; the or-variable was not bound at all
		(let ( 
		      (ctyp (get_ctype nmatch env))
		      (cbind (instance class_normal_let_binding
				       :letbind_loc sloc
				       :binder patsym
				       :letbind_type ctyp
				       :letbind_expr nmatch
				       ))
		      (clocc (instance class_nrep_locsymocc
				       :nrep_loc sloc
				       :nocc_ctyp ctyp
				       :nocc_symb patsym
				       :nocc_bind cbind))
		      )
		  (debug_msg clocc "normpat_variablepat fresh orvariable clocc")
		  (put_fields lococc :norvar_locsym clocc)
		  (debug_msg lococc "normpat_variablepat updated fresh orvariable lococc")
		  )
		)
	      ;;
	      ;; the or-variable was already bound within the same
	      ;; disjunct, so generate or reuse a same test
	      ( (is_a realococc class_nrep_locsymocc)
		(debug_msg realococc "normpat_variablepat bound orvariable realococccc")
		(normvarpat_genreusetest sloc nmatch realococc testlist tstuff hdler pcn)
		)
	      ;; the or-variable was already bound in a previous
	      ;; disjunction
	      ( (is_box realococc)
		(let ( 
		      (ctyp (get_ctype nmatch env))
		      (bxclocc (box_content realococc))
		      )
		  (debug_msg bxclocc "normpat_variablepat bxclocc")
		  (assert_msg "check bxclocc" (is_a bxclocc class_nrep_locsymocc))
		  (put_fields lococc :norvar_locsym bxclocc)
		  (debug_msg lococc "normpat_variablepat updated reusing orvariable lococc")
		))
	      ;; unexpected case
	      (:else
	       (assert_msg "normpat_variablepat corruption" ())
	       )
	      )
	)
      )
     ;; else patvar unbound, so bind it 
     ((null lococc)
      (let ( (ctyp (get_ctype nmatch env))
	     (cbind (instance class_normal_let_binding
			      :letbind_loc sloc
			      :binder patvar
			      :letbind_type ctyp
			      :letbind_expr nmatch
			      ))
	     (clocc (instance class_nrep_locsymocc
			      :nrep_loc sloc
			      :nocc_ctyp ctyp
			      :nocc_symb patvar
			      :nocc_bind cbind))
	     )
	(debug_msg ctyp "normpat_variablepat ctyp")
	(debug_msg clocc "normpat_variablepat new clocc")
	(shortbacktrace_dbg "normpat_variablepat:: new clocc" 12)
	;; put the clocc in the symbol cache map
	(mapobject_put (get_field :nctx_symbcachemap ncx) patvar clocc)
	(mapobject_put pvarmap patvar clocc)
	(debug_msg patvar "normpat_variablepat updated patvar")
	(debug_msg clocc "normpat_variablepat updated clocc")
	(debug_msg pvarmap "normpat_variablepat updated pvarmap")
	)
      )
     (:else
      (assert_msg "normpat_variablepat unexpected lococc" ())
      )
     )
    )
  )
(install_method class_source_pattern_variable normal_pattern normpat_variablepat)
;;;;;;;;;;;;;;;;





;;; normalize joker pattern
(defun normpat_jokerpat (recv nmatch hdler pcn)
  (debug_msg recv "normpat_jokerpat recv")
  (debug_msg nmatch "normpat_jokerpat nmatch")
  (assert_msg "check recv" (is_a recv class_source_pattern_joker_variable))
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  ;; we need nothing more, a joker pattern is essentially a black hole..
)
(install_method class_source_pattern_joker_variable normal_pattern normpat_jokerpat)
;;;;;;;;;;;;;;;;

;;; normalize an as pattern
(defun normpat_aspat  (recv nmatch hdler pcn)
  (debug_msg recv "normpat_aspat recv")
  (debug_msg nmatch "normpat_aspat nmatch")
  (debug_msg hdler "normpat_aspat hdler")
  (assert_msg "check recv" (is_a recv class_source_pattern_as))
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (shortbacktrace_dbg "normpat_aspat start" 15)
  (let (
	(sloc (get_field :loca_location recv))
	(aspat (get_field :aspat_varpat recv))
	(subpat (get_field :aspat_subpat recv))
	(testvarcont (instance class_container))
	)
    (debug_msg aspat "normpat_aspat before normalizing aspat")
    (assert_msg "check aspat" (is_a aspat class_source_pattern_variable))
    (normal_pattern 			;;this is normpat_variablepat
     aspat nmatch
     (lambda (tester) 
       (debug_msg tester "normpat_aspat lambda do tester")
       (debug_msg recv "normpat_aspat lambda recv")
       (put_fields testvarcont :container_value tester) 
       (shortbacktrace_dbg "normpat_aspat lambda" 15)
       (hdler tester)
       (debug_msg tester "normpat_aspat lambda did tester")
       ) 
     pcn)
    (debug_msg testvarcont "normpat_aspat testvarcont")
    (let ( (testvar (unsafe_get_field :container_value testvarcont)) 
	   )
      (debug_msg testvar "normpat_aspat testvar")
      (debug_msg subpat "normpat_aspat subpat")
      (normal_pattern 
       subpat nmatch
       (if testvar
	   (lambda (subtester) 
	     (debug_msg subtester "normpat_aspat lambda subtester with testvar")
	     (debug_msg recv "normpat_aspat lambda subtester with testvarrecv")
	     (shortbacktrace_dbg "normpat_aspat lambda subtester with testvar" 15)
	     (set_new_tester_last_then subtester testvarcont)
	     )
	 (lambda (subtester)
	   (debug_msg subtester "normpat_aspat lambda subtester without testvar")
	   (debug_msg recv "normpat_aspat lambda subtester  without testvar recv")
	   (debug_msg hdler "normpat_aspat lambda subtester  without testvar hdler")
	   (shortbacktrace_dbg "normpat_aspat lambda nosubtester" 15)
	   (hdler subtester)
	   (debug_msg subtester "normpat_aspat lambda subtester after hdler")
	   ))
       pcn)
      (debug_msg recv "normpat_aspat end recv")
      )))
(install_method class_source_pattern_as normal_pattern normpat_aspat)





;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; normalize instance pattern
(defun normpat_instancepat (recv nmatch hdler pcn)
  (debug_msg recv "normpat_instancepat recv start")
  (debug_msg nmatch "normpat_instancepat nmatch")
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (assert_msg "check recv" (is_a recv class_source_pattern_instance))
  (let ( (psloc (get_field :loca_location (get_field :pctn_src pcn)))
	 (sloc (get_field :loca_location recv))
	 (env (unsafe_get_field :pctn_env pcn))
	 (patcla (get_field :spat_class recv))
	 (patfields (get_field :spat_fields recv))
	 (oldenv env)
	 (ncx (get_field :pctn_normctxt pcn))
	 (stuffmap (get_field :pctn_stuffmap pcn))
	 (tstuff (mapobject_get stuffmap nmatch))
	 (tester ())
	 (curhdler hdler)
	 (testlist (get_field :pctn_tests pcn))
	 ;; we know for sure that patcla is a class_class
	 ;; hence its normalization does not make any bindings!
	 (npatcla (normal_exp patcla env ncx sloc))
	 )
    (assert_msg "check patcla" (is_a patcla class_class))
    ;; find the tester in the stuff
    (forever
     loopstuff
     (debug_msg tstuff "normpat_instancepat loop tstuff")
     ;; check if tstuff is a class_normtester_instance with good :ntinst_class
     (cond
      ( (== (get_field :ntinst_class tstuff) patcla)
	(setq tester tstuff)
	(exit loopstuff)
	)
      ((is_a tstuff class_normtester_any)
       (setq tstuff (get_field :ntest_else tstuff))
       (setq curhdler
	     (lambda (tester)
	       (shortbacktrace_dbg "normpat_instancepat lambda" 15)
	       (put_fields tstuff :ntest_else tester)
	       (debug_msg tstuff "normpat_instancepat lambda updatelse of tstuff")
	       (list_append (get_field :ntest_comefrom tester) tstuff)
	       ))
       )
      (:else
       (let ( 
	     (newfieldlocs
	      (make_multiple 
	       discr_multiple
	       (multiple_length (get_field :class_fields patcla))
	       ))
	     (newtester 
	      (instance class_normtester_instance
			:nrep_loc sloc
			:ntest_matched nmatch
			:ntest_then ()
			:ntest_else ()
			:ntest_locclist (make_list discr_list)
			:ntest_comefrom (make_list discr_list)
			:ntinst_class npatcla
			:ntinst_fieldlocs newfieldlocs
			))
	     )
	 (debug_msg newtester "normpat_instancepat newtester")
	 (register_new_normtester newtester pcn)
	 (setq tester newtester)
	 (list_append testlist newtester)
	 (debug_msg curhdler "normpat_instancepat before calling curhdler")
	 (curhdler tester)
	 (debug_msg curhdler "normpat_instancepat after calling curhdler")
	 (exit loopstuff)
	 )
       ))
     )
    (debug_msg tester "normpat_instancepat tester")
    (debug_msg recv "normpat_instancepat recv after tester")
    (debug_msg patcla "normpat_instancepat patcla")
    (let ( (testloccl (get_field :ntest_locclist tester)) 
	   (testercont (instance class_container
				 :container_value tester
				 ))
	   )
      (debug_msg testercont "normpat_instancepat testercont before loop")
      (assert_msg "check testbindl" (is_list testloccl))
      (foreach_in_multiple
       (patfields)
       (curpatf :long patix)
       (debug_msg curpatf "normpat_instancepat curpatf in loop")
       (debug_msg testercont "normpat_instancepat testercont in loop")
       (assert_msg "check curpatf" (is_a curpatf class_source_field_pattern))
       (let ( (floc (get_field :loca_location curpatf))
	      (curfld (get_field :spaf_field curpatf))
	      (cursubpat (get_field :spaf_pattern curpatf))
	      (curfldcla (get_field :fld_ownclass curfld))
	      (subhdler 
	       (lambda (newsubtester)
		 (debug_msg newsubtester "normpat_instancepat.subhdler newsubtester")
		 (debug_msg testercont "normpat_instancepat.subhdler testercont")
		 (shortbacktrace_dbg "normpat_instancepat.subhdler" 16)
		 (let ( (prevtester (get_field :container_value testercont)) )
		   (debug_msg prevtester "normpat_instancepat.subhdler prevtester")
		   (assert_msg "check prevtester" (is_a prevtester class_normtester_anytester))
		   (set_new_tester_last_then newsubtester testercont)
		   )
		 (debug_msg newsubtester "normpat_instancepat.subhdler end newsubtester")
		 ))
	      )
	 (debug_msg curfld "normpat_instancepat curfld")
	 (cond  ( (== curfldcla patcla) ())
		( (subclass_of patcla curfldcla) ())
		(:else (error_strv floc "bad field in instance pattern" (get_field :named_name curfld))))
	 (debug_msg cursubpat "normpat_instancepat before normal_pattern cursubpat")
	 (let ( (curloccl ())
		)
	   (debug_msg testloccl "normpat_instancepat scanning testloccl")
	   ;; try to find an existing local occurrence for the field
	   (foreach_in_list 
	    (testloccl)
	    (testpair testlocsy)
	    (assert_msg "check testlocsy" (is_a testlocsy class_nrep_locsymocc))
	    (if (== curfld
		    (get_field :nuget_field (get_field :letbind_expr (get_field :nocc_bind testlocsy))))
		(progn
		  (setq testpair ())	;to exist from foreach
		  (setq curloccl testlocsy)))
	    )
	   (debug_msg curloccl "normpat_instancepat got curloccl")
	   ;; if no local occurrence found, add a new one
	   (if (null curloccl)
	       (let ( 
		     (newsym (clone_symbol (get_field :named_name curfld))) 
		     (nflexp (instance class_nrep_unsafe_get_field
				       :nrep_loc floc
				       :nuget_obj nmatch
				       :nuget_field curfld))
		     (newbind (instance class_normal_let_binding
					:binder newsym
					:letbind_type ctype_value
					:letbind_expr nflexp
					:letbind_loc floc))
		     (newlocc (instance class_nrep_locsymocc
					:nrep_loc floc
					:nocc_ctyp ctype_value
					:nocc_symb newsym
					:nocc_bind newbind
					))
		     )
		 (multiple_put_nth 
		  (get_field :ntinst_fieldlocs tester) 
		  (get_int curfld)
		  newlocc)
		 ;; put the newlocc in the symbol cache map
		 (mapobject_put (get_field :nctx_symbcachemap ncx) newsym newlocc)
		 (debug_msg tester "normpat_instancepat updated fieldlocs tester")
		 (list_append testloccl newlocc)
		 (debug_msg newlocc "normpat_instancepat made newlocc")
		 (setq curloccl newlocc)
		 ))
	   (debug_msg cursubpat "normpat_instancepat before normal_pattern cursubpat")
	   (normal_pattern cursubpat curloccl subhdler pcn)
	   (debug_msg cursubpat "normpat_instancepat after normal_pattern cursubpat")
	   (debug_msg curpatf "normpat_instancepat did curpatf")
	   )
	 )))
    (debug_msg tester "normpat_instancepat final tester")
    )
  (debug_msg recv "normpat_instancepat recv end")
  )
(install_method class_source_pattern_instance normal_pattern normpat_instancepat)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; normalize a conjonction [and of subpatterns]
(defun normpat_andpat (recv nmatch hdler pcn)
  (debug_msg recv "normpat_andpat recv")
  (debug_msg nmatch "normpat_andpat nmatch")
  (debug_msg pcn "normpat_andpat pcn")
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (assert_msg "check recv" (is_a recv class_source_pattern_and))
  (let (
	(sloc (get_field :loca_location recv))
	(conjpats (get_field :andpat_conj recv))
	(testercont (instance class_container))
	(subhdler
	 (lambda (newtester) 
	   (debug_msg newtester "normpat_andpat.subhdler newtester")
	   (debug_msg testercont "normpat_andpat.subhdler testercont")
	   (let ( (prevtester (get_field :container_value testercont)) )
	     (cond
	      ((is_a prevtester class_normtester_any)
	       (debug_msg prevtester "normpat_andpat.subhdler prevtester")
	       (set_new_tester_last_then newtester testercont)
	       )
	      (:else
	       (debug_msg newtester "normpat_andpat.subhdler before calling hdler")
	       (hdler newtester)
	       (put_fields testercont :container_value newtester)
	       (debug_msg newtester "normpat_andpat.subhdler after calling hdler")
	       ))
	     (debug_msg testercont "normpat_andpat.subhdler done testercont")
	     )))
	)
    (foreach_in_multiple 
     (conjpats)
     (subpat :long subix)
     (debug_msg testercont "normpat_andpat testercont")
     (debug_msg subpat "normpat_andpat subpat before normal_pattern")
     (normal_pattern subpat nmatch subhdler pcn)
     (debug_msg subpat "normpat_andpat subpat after normal_pattern")
     (debug_msg testercont "normpat_andpat subpat testercont")
     )
    (debug_msg recv "normpat_andpat recv end")
    ))
(install_method class_source_pattern_and normal_pattern normpat_andpat)




;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; normalize a disjunction [or of subpatterns]
(defun normpat_orpat (recv nmatch hdler pcn)
  (debug_msg recv "normpat_orpat recv")
  (shortbacktrace_dbg "normpat_orpat called" 16)
  (debug_msg nmatch "normpat_orpat nmatch")
  (debug_msg pcn "normpat_orpat pcn")
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (assert_msg "check recv" (is_a recv class_source_pattern_or))
  (let (
	(sloc (get_field :loca_location recv))
	(disjpats (get_field :orpat_disj recv))
	(testercont (instance class_container))
	(clrlocbox (make_box discr_box ()))
	(lisubtesters (make_list discr_list))
	(freshlist (make_list discr_list))
	(testlist (get_field :pctn_tests pcn))
	(stuffmap (get_field :pctn_stuffmap pcn))
	(pvarmap (get_field :pctn_pvarlocmap pcn)) 
	(mapor (get_field :pctn_mapor pcn))
	(ncx (get_field :pctn_normctxt pcn))
	(orvarmap (mapobject_get mapor recv))
	#|
	(subhdler
	(lambda (newtester) 
	(debug_msg newtester "normpat_orpat.subhdler newtester")
	(debug_msg testercont "normpat_orpat.subhdler testercont")
	(shortbacktrace_dbg "normpat_orpat.subhdler labmda newtester" 14)
	(let (
	(prevtester (get_field :container_value testercont)) 
	)
	(if newtester
	(let (
	(orcleartester (instance class_normtester_orclear
	:nrep_loc sloc
	:ntest_matched nmatch
	:ntest_then ()
	:ntest_else ()
	:ntest_comefrom (make_list discr_list)
	:ntorclear_locsym (box_content clrlocbox)
	))
	)
	(assert_msg "check newtester" (is_a newtester class_normtester_any))
	(debug_msg newtester "normpat_orpat.subhdler newtester")
	(debug_msg orcleartester "normpat_orpat.subhdler orcleartester")
	(set_new_tester_all_elses orcleartester newtester)
	(list_append testlist orcleartester)
	(list_append lisubtesters newtester)))
	(cond
	((is_a prevtester class_normtester_anytester)
	(debug_msg prevtester "normpat_orpat.subhdler prevtester")
	(set_new_tester_all_elses newtester prevtester)
	)) 
	(debug_msg newtester "normpat_orpat.subhdler before calling hdler")
	(put_fields testercont :container_value newtester)
	(debug_msg newtester "normpat_orpat.subhdler after calling hdler")
	)
	(debug_msg testercont "normpat_orpat.subhdler done testercont")
	))
	|#
	) 
    (debug_msg stuffmap "normpat_orpat orig stuffmap")
    (debug_msg pvarmap "normpat_orpat orig pvarmap")
    (debug_msg orvarmap "normpat_orpat orvarmap")
    (assert_msg "check orvarmap" (is_mapobject orvarmap))
    ;; prebind the or variables
    (let ( (sortedorvars (mapobject_sorted_attribute_tuple orvarmap))
	   (sortedlococcs (make_multiple discr_multiple (multiple_length sortedorvars)))
	   (sortednormalvars
	    (multiple_map
	     sortedorvars
	     (lambda (orvar :long orix)
	       (debug_msg orvar "normpat_orpat.lambda orvar start")
	       (let (
		     (curvarpat (mapobject_get orvarmap orvar))
		     (curnorvar
		      (instance class_normal_or_variable
				:norvar_patvar curvarpat
				:norvar_nrepor ()
				:norvar_locsym ()))
		     (prevar (mapobject_get pvarmap orvar))
		     )
		 (assert_msg "check curvarpat"
			     (is_a curvarpat class_source_pattern_variable))
		 (if (null prevar)
		     (list_append freshlist orvar))
		 (put_int curnorvar orix)
		 (mapobject_put pvarmap orvar curnorvar)
		 curnorvar
		 ))))
	   )
      (box_put clrlocbox sortedlococcs)
      (debug_msg freshlist "normpat_orpat freshlist")
      (debug_msg sortedorvars "normpat_orpat sortedorvars")
      (debug_msg sortednormalvars "normpat_orpat sortednormalvars")
      (debug_msg sortedlococcs "normpat_orpat sortedlococcs")
      ;; sortedorvars is a sorted tuple of symbols
      ;;
      ;; normalize each disjunct
      (let ( (prevtestbox (make_box discr_box ()))
	    )
      (foreach_in_multiple 
       (disjpats)
       (subpat :long subix)
       ;; reset all the or- variables to a starting state
       (foreach_in_multiple
	(sortednormalvars)
	(curnorvar :long nix)
	(assert_msg "check curnorvar for disjunct" (is_a curnorvar class_normal_or_variable))
	(let ( (norvar (multiple_nth sortedorvars nix)) 
	       (norlocc (unsafe_get_field :norvar_locsym curnorvar))
	       )
	  ;; if the curnorvar has alrady a locsymocc, box it to reuse
	  ;; it without generating a same test!
	  (if (is_a norlocc class_nrep_locsymocc)
	      (put_fields curnorvar :norvar_locsym (make_box discr_box norlocc)))
	  (mapobject_put pvarmap norvar curnorvar)
	  (debug_msg norvar "normpat_orpat presetting norvar")
	  (debug_msg curnorvar "normpat_orpat preset curnorvar")
	  )
	)
       ;; normalize the current subpattern
       (debug_msg testercont "normpat_orpat testercont")
       (debug_msg subpat "normpat_orpat subpat before normal_pattern")
       (let (
	     (prevtest (box_content prevtestbox))
	     (prevloc (get_field :nrep_loc prevtest))
	     (norclear (instance class_normtester_orclear
				 :nrep_loc sloc
				 :ntest_matched nmatch
				 :ntest_then ()
				 :ntest_else ()
				 :ntest_comefrom (make_list discr_list)
				 :ntorclear_locsym (box_content clrlocbox)
			))
	     (subdisjhandler
	       (lambda (disjntester)
		 (debug_msg disjntester "normpat_orpat.subdisjhandler disjntester")
		 (debug_msg subpat "normpat_orpat.subdisjhandler subpat")
		 (debug_msg prevtest "normpat_orpat.subdisjhandler prevtest")
		 (cond 
		  ( (is_a disjntester class_normtester_anytester)
		    (unsafe_put_fields norclear :ntest_then disjntester)
		    (box_put prevtestbox disjntester)
		    (list_append lisubtesters disjntester)
		    (if prevtest 
			(progn
			  (debug_msg prevtest "normpat_orpat.subdisjhandler setelse of prevtest")
			  (debug_msg norclear "normpat_orpat.subdisjhandler setelse to norclear")
			  (set_new_tester_all_elses prevtest norclear)
			  ))
		    )
		  ( (and (is_object disjntester) prevtest)
		    (warning_plain (or (get_field :nrep_loc disjntester) sloc)
				   "maybe degenerate disjunct in OR pattern")
		    (debug_msg disjntester "normpat_orpat.subdisjhandler disjntester degenerate")
		    (debug_msg prevtest "normpat_orpat.subdisjhandler prevtest degenerate")
		    (set_new_tester_all_elses prevtest disjntester)
		    )
		  (:else
		    (error_plain sloc "bad disjunct in OR pattern")
		    (debug_msg disjntester "normpat_orpat.subdisjhandler disjntester")
		     )
		 )
		 ))
	     )
	 (debug_msg prevtest "normpat_orpat prevtest before normal_pattern")
	 (debug_msg subpat "normpat_orpat subpat before normal_pattern")
	 (normal_pattern subpat nmatch subdisjhandler pcn)
	 (debug_msg subpat "normpat_orpat subpat after normal_pattern")
       )
       (debug_msg testercont "normpat_orpat testercont after normal_pattern")
       (debug_msg stuffmap "normpat_orpat after normal_pattern stuffmap")
       (debug_msg pvarmap "normpat_orpat after normal_pattern pvarmap")
       )) ;;;; end foreach_in_multiple disjpats
      ;;
      ;; postbind the norvar
      (debug_msg sortednormalvars "normpat_orpat sortednormalvars postbind")
      (debug_msg sortedorvars "normpat_orpat sortedorvars postbind")
      (foreach_in_multiple
       (sortednormalvars)
       (curnorvar :long nix)
       (let ( (norvar (multiple_nth sortedorvars nix)) 
	      (norlococc (get_field :norvar_locsym curnorvar))
	      )
	 (debug_msg norvar "normpat_orpat postbind norvar")
	 (debug_msg norlococc "normpat_orpat postbind norlococc")
	 (assert_msg "check norlococc" (is_a norlococc class_nrep_locsymocc))
	 (multiple_put_nth sortedlococcs nix norlococc)
	 (mapobject_put pvarmap norvar norlococc)
	 ))
      (debug_msg sortedlococcs "normpat_orpat updated sortedlococcs")
      (let  (
	     (subtesters (list_to_multiple lisubtesters))
	     (:long nbsubtesters (multiple_length subtesters))
	     )
	(debug_msg subtesters "normpat_orpat subtesters")
	(if (<i nbsubtesters 2)
	    (warning_plain sloc "this OR pattern has less than two tests so is degenerated")
	  ;; we might check for an equivalent disjunction, but it is
	  ;; useless in practice...
	  (let ( (disjtester (instance class_normtester_disjunction 
				       :nrep_loc sloc
				       :ntest_matched nmatch
				       :ntest_then ()
				       :ntest_else (multiple_nth subtesters 0)
				       :ntest_comefrom (make_list discr_list)
				       :ntdisjuncts subtesters
				       )) )
	    (foreach_in_multiple
	     (sortednormalvars)
	     (curnorvar :long nix)
	     (put_fields curnorvar :norvar_nrepor disjtester)
	     (debug_msg curnorvar "normpat_orpat updated curnorvar")
	     )
	    ;; scan the freshlist using the sortednormalvars
	    (let ( (:long fnix 0) 
		   (:long nbv (multiple_length sortedorvars))
		   )
	      (foreach_in_list
	       (freshlist)
	       (curpair curfreshsy)
	       (debug_msg curfreshsy "normpat_orpat curfreshsy")
	       (let
		   ( (foundnorvar
		      (forever 
		       upvarloop
		       (assert_msg "check fnix" (<i fnix nbv))
		       (let ( (curnorvar (multiple_nth sortednormalvars fnix)) )
			 (if (== (get_field :spat_var 
					    (get_field :norvar_patvar curnorvar))
				 curfreshsy)
			     (exit upvarloop curnorvar))
			 )
		       (setq fnix (+i fnix 1))
		       )
		      )
		     )
		 (debug_msg foundnorvar "normpat_orpat foundnorvar")
		 (let ( (foundlocc (get_field :norvar_locsym foundnorvar)) 
			(ctyp (get_field :nocc_ctyp foundlocc))
			(fsymb (get_field :nocc_symb foundlocc))
			(cbind (get_field :nocc_bind foundlocc))
			)
		   (debug_msg foundlocc "normpat_orpat foundlocc")
		   (assert_msg "check foundlocc" (is_a foundlocc class_nrep_locsymocc))
		   ;; put the foundlocc in the symbol cache map
		   (mapobject_put  (get_field :nctx_symbcachemap ncx) fsymb foundlocc)
		   (mapobject_put pvarmap fsymb foundlocc)
		   (debug_msg fsymb "normpat_orpat fsymb")
		   )
		 )
	       )
	      )
	    (debug_msg disjtester "normpat_orpat disjtester")
	    (register_new_normtester disjtester pcn)
	    (hdler disjtester)
	    (list_append testlist disjtester)
	    (debug_msg disjtester "normpat_orpat handled disjtester")
	    ))
	)
      )
    )
  (debug_msg recv "normpat_orpat recv end")
  )
(install_method class_source_pattern_or normal_pattern normpat_orpat)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; normalize anymatcher pattern
(defun normpat_anymatchpat (recv nmatch hdler pcn)
  (debug_msg recv "normpat_anymatchpat recv")
  (debug_msg nmatch "normpat_anymatchpat nmatch")
  (debug_msg pcn "normpat_anymatchpat pcn")
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (assert_msg "check recv" (is_a recv class_source_pattern_matcher))
  (shortbacktrace_dbg "normpat_anymatchpat start" 14)
  (let (
	(sloc (get_field :loca_location recv))
	(mat (get_field :spac_operator recv))
	(matopbind (get_field :spac_operbind recv))
	(inargs (get_field :spac_inargs recv))
	(outargs (get_field :spac_outargs recv))
	(env (unsafe_get_field :pctn_env pcn))
	(oldenv env)
	(ncx (unsafe_get_field :pctn_normctxt pcn))
	(bindlist (unsafe_get_field :pctn_bindlist pcn))
	(stuffmap (unsafe_get_field :pctn_stuffmap pcn))
	(matchctype (get_ctype nmatch env))
	(testlist (get_field :pctn_tests pcn))
	)
    (assert_msg "check mat" (is_a mat class_any_matcher))
    (assert_msg "check matopbind" (is_a matopbind class_any_binding))
    (debug_msg inargs "normpat_anymatchpat inargs")
    (debug_msg mat "normpat_anymatchpat mat")
    (debug_msg matopbind "normpat_anymatchpat matopbind")
    (let ( 
	  (matvar (let ( (mv (get_field :binder matopbind)) )
		    (debug_msg mv "normpat_anymatchpat matvar")
		    (assert_msg "check matvar's binding"
				(== (find_env env mv) matopbind))
		    mv
		    ))
	  ;; we know that matvar is a symbol so its normalization
	  ;; returns a single value
	  (matndata (normal_exp matvar env ncx sloc))
	  )
      (debug_msg matndata "normpat_anymatchpat matndata")
      (multicall
       (nins bindins)
       (normalize_tuple inargs env ncx sloc)
       (debug_msg nins "normpat_anymatchpat nins")
       (debug_msg bindins "normpat_anymatchpat bindins")
       (if bindins (list_append2list bindlist bindins))
       (let (
	     (inmatchs (get_field :amatch_in mat))
	     (outmatchs (get_field :amatch_out mat))
	     (matbind (get_field :amatch_matchbind mat))
	     (outbinds ())
	     (tester ())
	     )
	 ;; check compatibility of ctype
	 (if (!= matchctype (get_field :fbind_type matbind))
	     (progn
	       (error_strv sloc "unexpected matched type" (get_field :named_name matchctype))
	       (inform_strv sloc "expecting type in matcher" (get_field :named_name (get_field :fbind_type matbind)))))
	 ;; input args
	 (debug_msg inargs "normpat_anymatchpat inargs")
	 (debug_msg inmatchs "normpat_anymatchpat inmatchs")
	 (let ( (:long nbinargs  (multiple_length inargs)) )
	   (if (!=i nbinargs (multiple_length inmatchs))
	       (error_strv 
		sloc 
		"formal and actual number of input matching arguments differ for anymatch"
		(get_field :named_name mat)))
	   (if (>i nbinargs 0)
	       (let ( (newenv (fresh_env env)) )
		 (foreach_in_multiple
		  (nins)
		  (ncurin :long ix)
		  (debug_msg ncurin "normpat_anymatchpat ncurin")
		  (let ( (curmatch (multiple_nth inmatchs ix)) 
			 (curctype (get_ctype ncurin env))
			 (matchtype (get_field :fbind_type curmatch))
			 )
		    (debug_msg curmatch "normpat_anymatchpat curmatch")
		    (assert_msg "check curmatch" 
				(is_a curmatch class_formal_binding))
		    (debug_msg curctype "normpat_anymatchpat curctype")
		    (debug_msg matchtype "normpat_anymatchpat matchtype")
		    (if (!= curctype matchtype)
			(progn
			  (error_strv sloc
				      "type mismatch for match argument in matcher"
				      (get_field :named_name mat))
			  (inform_strv sloc
				       "mismatched formal name in matcher is"
				       (get_field :named_name (get_field :binder curmatch)))
			  (inform_strv sloc
				       "mismatched input type is"
				       (get_field :named_name curctype))
			  (inform_strv sloc
				       "expected match type is"
				       (get_field :named_name matchtype))
			  )
		      (let ( (newb (instance class_normal_let_binding
					     :letbind_loc sloc
					     :binder (get_field :binder curmatch)
					     :letbind_type curctype
					     :letbind_expr ncurin)
				   )
			     )
			(debug_msg newb "normpat_anymatchpat newb")
			(put_env newenv newb)
			))))
		 (setq env newenv)
		 (put_fields pcn :pctn_env newenv)
		 )))
	 ;; output args
	 (debug_msg outargs "normpat_anymatchpat outargs")
	 (debug_msg outmatchs "normpat_anymatchpat outmatchs")
	 (let ( (:long nboutargs (multiple_length outargs)) ) 
	   (if (!=i nboutargs (multiple_length outmatchs))
	       (error_strv 
		sloc 
		"formal and actual number of output matched arguments differ for anymatch"
		(get_field :named_name mat)))
	   (let ( (tstuff (mapobject_get stuffmap nmatch)) 
		  (curhdler hdler)
		  )
	     (forever 
	      loopstuff
	      (debug_msg tstuff "normpat_anymatchpat tstuff")
	      (cond 
	       ((and (is_a tstuff class_normtester_matcher)
		     (== (get_field :ntmatch_matcher tstuff) mat))
		(let ((tinargs (get_field :ntmatch_inargs tstuff)) 
		      (:long good 1)
		      )
		  (foreach_in_multiple
		   (tinargs)
		   (curinarg :long ix)
		   (let ( (nthins (multiple_nth nins ix)) )
		     (if (!= curinarg nthins)
			 (setq good 0)))
		   )
		  (if good 
		      (progn 
			(debug_msg tstuff "normpat_anymatchpat good tstuff")
			(setq tester tstuff)
			(exit loopstuff))
		    (progn
		      (setq tstuff (get_field :ntest_else tstuff))
		      (setq curhdler
			    (lambda (tester)
			      (shortbacktrace_dbg "normpat_anymatchpat lambda updating else" 15)
			      (put_fields tstuff :ntest_else tester)
			      (debug_msg tstuff "normpat_anymatchpat lambda updatelse of tstuff")
			      (list_append (get_field :ntest_comefrom tester) tstuff)
			      ))
		      ))
		  )
		(assert_msg "normpat_anymatchpat incomplete found tstuff" ())
		)
	       ((is_a tstuff class_normtester_any)
		(setq tstuff (get_field :ntest_else tstuff))
		(setq curhdler
		      (lambda (tester)
			(put_fields tstuff :ntest_else tester)
			(shortbacktrace_dbg "normpat_anymatchpat updatelse" 15)
			(debug_msg tstuff "normpat_anymatchpat updatelse tsuff")
			(list_append (get_field :ntest_comefrom tester) tstuff)
			))
		)
	       (:else
		(let
		    ( (outlocs
		       (multiple_map 
			outmatchs
			(lambda (curoutmatch :long ix)
			  (debug_msg curoutmatch "normpat_anymatchpat curoutmatch")
			  (assert_msg "check curoutmatch" (is_a curoutmatch class_formal_binding))
			  (let ( (csym (clone_symbol (get_field :binder curoutmatch)))
				 (curtyp (get_field :fbind_type curoutmatch))
				 (cbind (instance class_normal_let_binding
						  :letbind_loc sloc
						  :binder csym
						  :letbind_type curtyp
						  ;; this is really nil,
						  ;; the binding should
						  ;; be cleared
						  :letbind_expr ()
						  ))
				 (clocc (instance class_nrep_locsymocc
						  :nrep_loc sloc
						  :nocc_ctyp curtyp
						  :nocc_symb csym
						  :nocc_bind cbind))
				 )
			    ;; put the clocc in the symbol cache map
			    (mapobject_put (get_field :nctx_symbcachemap ncx) csym clocc)
			    clocc
			    ))))
		      (newtester 
		       (instance class_normtester_matcher
				 :nrep_loc sloc
				 :ntest_matched nmatch
				 :ntest_then ()
				 :ntest_else ()
;;;; one could imagine having some
;;;; subclass of cmatcher which add
;;;; additional local stuff...
				 :ntest_locclist (multiple_to_list outlocs)
				 :ntest_comefrom (make_list discr_list)
				 :ntmatch_matcher mat
				 :ntmatch_matndata matndata
				 :ntmatch_inargs nins
				 :ntmatch_outlocs outlocs
				 ))
		      )
		  (debug_msg newtester "normpat_anymatchpat newtester")
		  (register_new_normtester newtester pcn)
		  (setq tester newtester)
		  (list_append testlist newtester)
		  (shortbacktrace_dbg "normpat_anymatchpat before curhdler" 12)
		  (curhdler newtester)
		  (exit loopstuff)
		  ))
	       ))
	     )
	   )
	 (debug_msg tester "normpat_anymatchpat got tester")
	 (assert_msg "check tester" (is_a tester class_normtester_matcher))
	 ;;	
	 (let ( (outlocs (get_field :ntmatch_outlocs tester)) )
	   (debug_msg outlocs "normpat_anymatchpat outlocs from tester")
	   (debug_msg outargs "normpat_anymatchpat outargs before foreach")
	   (debug_msg outmatchs "normpat_anymatchpat outmatchs before foreach")
	   (foreach_in_multiple
	    (outmatchs)
	    (curmatch :long ixm)
	    (messagenum_dbg "normpat_anymatchpat ixm in outmatchs" ixm)
	    (debug_msg curmatch "normpat_anymatchpat curmatch in foreach")
	    (let ( (clocc (multiple_nth outlocs ixm)) 
		   (curout (multiple_nth outargs ixm))
		   (testercont (instance class_container
					 :container_value tester))
		   (subhdler 
		    ;; put the new tester as the last element of its
		    ;; ntest_then chain
		    (lambda (newtester)
		      (debug_msg newtester "normpat_anymatchpat subhdler newtester")
		      (shortbacktrace_dbg "normpat_anymatchpat subhdler" 14)
		      (set_new_tester_last_then newtester testercont)
		      ))
		   )
	      (debug_msg curout "normpat_anymatchpat curout before normal_pattern")
	      (debug_msg clocc "normpat_anymatchpat clocc before normal_pattern")
	      (shortbacktrace_dbg "normpat_anymatchpat before normal_pattern curout" 14)
	      (normal_pattern curout clocc subhdler pcn)
	      (debug_msg curmatch "normpat_anymatchpat curout after normal_pattern")
	      )
	    )
	   )
	 (debug_msg outbinds "normpat_anymatchpat outbinds")
	 )
       )
      )
    (if (!= env oldenv)
	(put_fields pcn :pctn_env oldenv))
    )
  )
(install_method class_source_pattern_matcher normal_pattern normpat_anymatchpat)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; 
;;;; normalize a constant pattern
(defun normpat_constpat (recv nmatch hdler pcn)
  (debug_msg recv "normpat_constpat recv")
  (debug_msg nmatch "normpat_constpat nmatch")
  (debug_msg pcn "normpat_constpat pcn")
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (assert_msg "check recv" (is_a recv class_source_pattern_constant))
  (let (
	(sloc (get_field :loca_location recv))
	(sconst (get_field :spat_constx recv))
	(stuffmap (get_field :pctn_stuffmap pcn))
	(pvarmap (get_field :pctn_pvarlocmap pcn)) 
	(psloc (get_field :loca_location (get_field :pctn_src pcn)))
	(tstuff (mapobject_get stuffmap nmatch))
	(env (get_field :pctn_env pcn))
	(ncx (get_field :pctn_normctxt pcn))
	(testlist (get_field :pctn_tests pcn))
	(mapcst (get_field :pctn_mapatcst pcn))
	)
;;; the constant has already been normalized in scanpat_srcpatconst
    (debug_msg tstuff "normpat_constpat tstuff")
    (let (
	  (tester ())
	  (curhdler hdler)
	  (nconst (if (is_object sconst) (mapobject_get mapcst sconst) sconst))
	  )
      (debug_msg nconst "normpat_constpat nconst")
      (forever 
       loopstuff
       (debug_msg tstuff "normpat_constpat tstuff")
       (cond
	( (== (get_field :ntsame_identical tstuff) nconst)
	  (setq tester tstuff)
	  (exit loopstuff))
	( (is_a tstuff class_normtester_any)
	  (setq tstuff (get_field :ntest_else tstuff))
	  (setq curhdler 
		(lambda (tester)
		  (put_fields tstuff :ntest_else tester)
		  (shortbacktrace_dbg "normpat_constpat lambda updatelse" 15)
		  (debug_msg tstuff "normpat_constpat lambda updatelse tstuff")
		  (list_append (get_field :ntest_comefrom tester) tstuff)
		  ))
	  )
	(:else
	 (let ( (newtester (instance class_normtester_same
				     :nrep_loc psloc
				     :ntest_matched nmatch
				     :ntest_then ()
				     :ntest_else ()
				     :ntest_locclist ()
				     :ntest_comefrom (make_list discr_list)
				     :ntsame_identical nconst))
		)
	   (shortbacktrace_dbg "normpat_constpat making newtester same" 15)
	   (register_new_normtester newtester pcn)
	   (debug_msg newtester "normpat_constpat newtester same")
	   (setq tester newtester)
	   (list_append testlist newtester)
	   (curhdler newtester)
	   (exit loopstuff)
	   )
	 )
	)
       )				;end forever
      (debug_msg tester "normpat_constpat got tester")
      )
    )
  )
(install_method class_source_pattern_constant normal_pattern normpat_constpat)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; normalize a match
(defun normexp_match (recv env ncx psloc)
  (assert_msg "check match recv" (is_a recv class_source_match))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normalization_context))
  (debug_msg recv "normexp_match recv")
  (let ( (sloc (unsafe_get_field :loca_location recv))
	 (smatsx (unsafe_get_field :smat_matchedx recv))
	 (scases (unsafe_get_field :smat_cases recv))
	 (:long nbcases (multiple_length scases))
	 (tupvarmap (make_multiple discr_multiple nbcases))
	 (tupcstmap (make_multiple discr_multiple nbcases))
	 ;; the shabindlist & the stuffmap are shared for all match cases
	 (stuffmap (make_mapobject discr_map_objects 
				   (+i 20 (*i 5 nbcases))))
	 (shabindlist (make_list discr_list))
	 (testlist (make_list discr_list))
	 (wholectype ())		;the ctype of the whole match
	 (oldtester ())			;the previous tester
	 )
    (debug_msg smatsx "normexp_match smatsx")
    (multicall
     (nmatx nbindmatx)
     (normal_exp smatsx env ncx sloc)
     (debug_msg nmatx "normexp_match nmatx")
     (debug_msg scases "normexp_match scases")
     (let ( (ctyp (get_ctype nmatx env)) 
	    )
       (debug_msg ctyp "normexp_match ctyp")
       ;; if the matched stuff is not an object, it is a constant, so
       ;; make a binding for it
       (if (not (is_object nmatx))
	   (let (
		 (csym (clone_symbol '_matched_))
		 (cbind (instance class_normal_let_binding
				  :letbind_loc sloc
				  :binder csym
				  :letbind_type ctyp
				  :letbind_expr nmatx))
		 (clocc (instance class_nrep_locsymocc
				  :nrep_loc sloc
				  :nocc_ctyp ctyp
				  :nocc_symb csym
				  :nocc_bind cbind))
		 )
	     (assert_msg "check no binding" (null nbindmatx))
	     ;; put the clocc in the symbol cache map
	     (mapobject_put (get_field :nctx_symbcachemap ncx) csym clocc)
	     (setq nbindmatx (list1 cbind))
	     (setq nmatx clocc)
	     ))
       ;; if no binding list, make an empty one
       (if (null nbindmatx) (setq nbindmatx (make_list discr_list)))
       ;;
       ;; loop on each case
       (foreach_in_multiple
	(scases)
	(curcas :long ix)
	(debug_msg curcas "normexp_match curcas")
	(assert_msg "check curcas" (is_a curcas class_source_match_case))
	(let ( 
	      (curloc (unsafe_get_field :loca_location curcas))
	      (curpat (unsafe_get_field :scam_patt curcas))
	      (curbody (unsafe_get_field :scam_body curcas))
	      (mapvar (make_mapobject discr_map_objects 13))
	      (mapcst (make_mapobject discr_map_objects 11))
	      (mapor (make_mapobject discr_map_objects 7))
	      (pvarmap (make_mapobject discr_map_objects 23))
	      (pcn (instance class_pattern_context
			     :pctn_normctxt ncx
			     :pctn_src recv
			     :pctn_env env
			     :pctn_mapatvar mapvar
			     :pctn_mapatcst mapcst
			     :pctn_mapor mapor
			     :pctn_bindlist shabindlist
			     :pctn_stuffmap stuffmap
			     :pctn_pvarlocmap pvarmap
			     :pctn_tests testlist
			     ))
	      (ntestcont (instance class_container)) ;container for tester
	      )
	  (debug_msg curpat "normexp_match curpat before scan_pattern")
	  ;; I am not entirely sure of this assert! Perhaps there maybe
	  ;; strange cases where curpat is null...
	  (assert_msg "normexp_match check curpat" curpat)
	  (scan_pattern curpat curloc ctyp pcn)
	  (debug_msg curpat "normexp_match curpat after scan_pattern")
	  (debug_msg mapvar "normexp_match mapvar")
	  (debug_msg pvarmap "normexp_match pvarmap")
	  (debug_msg mapcst "normexp_match mapcst")
	  (multiple_put_nth tupvarmap ix mapvar)
	  (multiple_put_nth tupcstmap ix mapcst)
	  (debug_msg shabindlist "normexp_match shabindlist before normal_pattern")
	  (debug_msg curpat "normexp_match curpat before normal_pattern")
	  ;; normalize the current pattern, with the handler storing its topmost tester
	  (normal_pattern 
	   curpat nmatx
	   (lambda (tester) 
	     (debug_msg tester "normexp_match.lambda tester")
	     (shortbacktrace_dbg "normexp_match lambda tester" 12)
	     (assert_msg "check empty ntestcont" 
			 (null (unsafe_get_field :container_value ntestcont)))
	     (put_fields ntestcont :container_value tester))
	   pcn)
	  (debug_msg curpat "normexp_match curpat after normal_pattern")
	  (debug_msg pvarmap "normexp_match pvarmap after normal_pattern")
	  (debug_msg ntestcont "normexp_match ntestcont after normal_pattern")
	  (debug_msg shabindlist "normexp_match shabindlist after normal_pattern")
	  ;; 
	  (let ( (newenv (get_field :pctn_env pcn))
		 (pvarlocmap (get_field :pctn_pvarlocmap pcn))
		 (curtester (get_field :container_value ntestcont))
		 ;; we need a success. For the last joker case, it
		 ;; becomes the curtester; for the usual case it is
		 ;; added as the last then. Anyway, it will contain
		 ;; the action part of the current case.
		 (newsuctester
		  (instance class_normtester_success
			    :nrep_loc curloc
			    ;; we really don't match anything
			    :ntest_matched ()
			    :ntest_then ()
			    :ntest_else ()
			    :ntest_comefrom (make_list discr_list)
			    ;; the success do should be the wrapped
			    ;; let of the normalized actions
			    :ntsuccess_do ()
			    ))
		 )
	    (debug_msg newenv "normexp_match newenv after normal_pattern")
	    (debug_msg newsuctester "normexp_match empty newsuctester")
	    (debug_msg pvarlocmap "normexp_match pvarlocmap after normal_pattern")
	    (debug_msg curcas "normexp_match curcas after normal_pattern")
	    (debug_msg curtester "normexp_match curtester after normal_pattern")
	    (debug_msg oldtester "normexp_match oldtester after normal_pattern")
	    ;; append the new success to the test list, so that it
	    ;; will get its ntest_normatch later
	    (list_append testlist newsuctester)
	    (cond 
	     ((null curtester)
	      (debug_msg curcas "normexp_match curcas for null curtester")
	      ;; curtester is null if the whole case is a joker,
	      ;; this should be the last case
	      (if (<i ix (-i (multiple_length scases) 1))
		  (error_plain sloc "joker case in MATCH is not last"))
	      ;; set the current tester to the success 
	      (setq curtester newsuctester)
	      (debug_msg curtester "normexp_match curestester set to success")
	      )
	     ;; else the curtester is not null; it cannot be a success
	     (:else
	      (assert_msg "check curtester not success" 
			  (is_not_a curtester class_normtester_success))
;;; add the newsuctester as the last then of the curtester
	      (let ( (curtestcont (instance class_container
					    :container_value curtester)) )
		(debug_msg curtestcont "normexp_match our curtestcont")
		(debug_msg newsuctester "normexp_match our newsuctester")
		(set_new_tester_last_then newsuctester curtestcont)
		(debug_msg curtestcont "normexp_match final curtestcont")
		)
	      ) ;; end when null curtester
	     )	;; end cond
	    (debug_msg curtester "normexp_match final curtester")
	    (assert_msg "check final curtester"  (is_a curtester class_normtester_any))
	    ;; if there is an oldtester, add the curtester as its last else case
	    (if (is_a oldtester class_normtester_anytester)
		(progn
		  (debug_msg oldtester "normexp_match initial oldtester")
		  (set_new_tester_all_elses curtester oldtester)
		  (debug_msg oldtester "normexp_match final oldtester")
		  ))
	    ;; always set the oldtester to the curtester
	    (setq oldtester curtester)
	    (debug_msg pcn "normexp_match pcn after lastesterloop")
	    (debug_msg pvarlocmap "normexp_match pvarlocmap after lastesterloop")
	    (let ( (sortedvars (mapobject_sorted_attribute_tuple pvarlocmap)) 
		   (sortedbindings (make_multiple discr_multiple (multiple_length sortedvars)))
		   (freshnewenv (fresh_env newenv))
		   )
	      (debug_msg sortedvars "normexp_match sortedvars")
	      ;; we have to make a list of bindings based upon the sortedvars
	      (foreach_in_multiple
	       (sortedvars)
	       (svar :long svix)
	       (debug_msg svar "normexp_match svar")
	       (let ( (socc (mapobject_get pvarlocmap svar))
		      )
		 (debug_msg socc "normexp_match socc")
		 (assert_msg "check socc" (is_a socc class_nrep_locsymocc))
		 (let ( (sbind (unsafe_get_field :nocc_bind socc)) )
		   (debug_msg sbind "normexp_match sbind")
		   (multiple_put_nth sortedbindings svix sbind)
		   (put_env freshnewenv sbind)
		   )
		 ))
	      (debug_msg freshnewenv "normexp_match freshnewenv")
	      (debug_msg sortedbindings "normexp_match sortedbindings")
	      (assert_msg "check sortedbindings" (is_multiple sortedbindings))
	      (let ( (subindlist (make_list discr_list)) 
		     )
		(foreach_in_multiple
		 (sortedbindings)
		 (cursortbind :long sortbix)
		 (debug_msg cursortbind "normexp_match cursortbind")
		 (assert_msg "check cursortbind" 
			     (is_a cursortbind class_normal_let_binding))
		 (list_append subindlist cursortbind)
		 )
		(debug_msg curbody "normexp_match curbody before normalize_tuple")
		(multicall 
		 (nbody bindsbody)
		 (normalize_tuple curbody freshnewenv ncx curloc)
		 (debug_msg curbody "normexp_match curbody after normalize_tuple")
		 (debug_msg nbody "normexp_match nbody")
		 (debug_msg bindsbody "normexp_match bindsbody")
		 (assert_msg "check bindsbody" (is_list_or_null bindsbody))
		 (foreach_in_list
		  (bindsbody)
		  (bindbodypair curbindbody)
		  (debug_msg curbindbody "normexp_match curbindbody")
		  (list_append subindlist curbindbody)
		  )
		 (debug_msg subindlist "normexp_match final subindlist")
		 (let ( (wnlet (wrap_normal_letseq nbody subindlist curloc)) 
			(lastnbody (multiple_nth nbody -1))
			(lastctype (get_ctype lastnbody freshnewenv))
			)
		   (debug_msg wnlet "normexp_match wnlet")
		   (debug_msg lastnbody "normexp_match lastnbody")
		   (debug_msg lastctype "normexp_match lastctype")
		   (put_fields newsuctester 
			       :ntsuccess_do wnlet
			       )
		   (cond ( (null wholectype)
			   (setq wholectype lastctype))
			 ( (== lastctype ctype_void)
			   (setq wholectype ctype_void))
			 ( (== wholectype ctype_void)
			   ())
			 ( (!= wholectype lastctype)
			   (error_strv curloc "invalid type of match case" 
				       (get_field :named_name lastctype))
			   (inform_strv sloc "expected type of match case"
					(get_field :named_name wholectype)))
			 )
		   (debug_msg newsuctester "normexp_match updated newsuctester")
		   ))))))) ;;; end foreach_in_multiple
       ;; end of loop on each case
       (debug_msg tupvarmap "normexp_match tupvarmap")
       (debug_msg tupcstmap "normexp_match tupcstmap")
       (debug_msg testlist "normexp_match testlist")
       (debug_msg stuffmap "normexp_match stuffmap")
       (debug_msg (let ( (stmpklist (make_list discr_list)) )
		    (foreach_in_mapobject
		     (stuffmap)
		     (lococck litest)
		     (list_append stmpklist lococck)
		     )
		    stmpklist) 
		  "normexp_match stuffmapkeylist")
       (let ( 
	     (teststupl (let ( (tt (list_to_multiple testlist)) )
			  (debug_msg tt "normexp_match teststupl")
			  tt))
	     (nmatch (instance class_nrep_match
			       :nrep_loc sloc
			       :nexpr_ctyp wholectype
			       :nmatch_tests teststupl
			       :nmatch_stuffmap stuffmap
			       :nmatch_matched nmatx
			       ))
	     (csym (clone_symbol 'matchres_))
	     (clocc  (instance  class_nrep_locsymocc
				:nrep_loc sloc
				:nocc_ctyp wholectype
				:nocc_symb csym)) 
	     (cbind (instance class_normal_let_binding
			      :letbind_loc sloc
			      :binder csym
			      :letbind_type wholectype
			      :letbind_expr nmatch))
	     )
	 (debug_msg csym "normexp_match csym")
	 (put_fields clocc :nocc_bind cbind)
	 (debug_msg clocc "normexp_match clocc")
	 ;; put the clocc in the symbol cache map
	 (mapobject_put (get_field :nctx_symbcachemap ncx) csym clocc)
	 ;; put the index of each test 
	 (foreach_in_multiple
	  (teststupl)
	  (curtest :long tstix)
	  (debug_msg curtest "normexp_match raw curtest")
	  (assert_msg "check curtest" (is_a curtest class_normtester_any))
	  (assert_msg "check tstix" (>=i tstix 0))
	  (assert_msg "check tstix not too big" (<i tstix 32767))
	  (messagenum_dbg "normexp_match testindex tstix" tstix)
	  (put_int curtest tstix)
	  (put_fields curtest :ntest_normatch nmatch)
	  (debug_msg curtest "normexp_match indexed curtest")
	  )
	 (unsafe_put_fields clocc :nocc_bind cbind)
	 (debug_msg teststupl "normexp_match final teststupl")
	 (debug_msg nbindmatx "normexp_match before append nbindmatx")
	 (assert_msg "check nbindmatx" (is_list nbindmatx))
	 (list_append nbindmatx cbind)
	 (debug_msg nmatch "normexp_match final nmatch")
	 (debug_msg cbind "normexp_match final cbind")
	 (debug_msg nbindmatx "normexp_match returned nbindmatx")
	 (debug_msg clocc "normexp_match returned clocc")
	 (return clocc nbindmatx)
	 )))))


(install_method class_source_match normal_exp normexp_match)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; export our classes
(export_class
 class_pattern_context
 class_normtester_any
 class_normtester_anytester
 class_normtester_disjunction
 class_normtester_instance
 class_normtester_matcher
 class_normtester_orclear
 class_normtester_same
 class_normtester_success
 class_nrep_match
 )

;;; export our values
(export_values
 scan_pattern
 normal_pattern
 )

;; eof warmelt-normatch.melt