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

    This file is part of GCC.

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

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

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

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


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


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

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


;;; class for the context of normalization of patterns
(defclass class_pattern_context
  :super class_root
  :doc #{The $CLASS_PATTERN_CONTEXT is for context of patterns'
normalization. $PCTN_NORMCTXT is the
$CLASS_NORMALIZATION_CONTEXT. $PCTN_SRC is the source match
expression. $PCTN_MAPATVAR is the mapping from symbols to pattern
variables. $PCTN_MAPATCNST is the mapping from constant objects to
pattern constants. $PCTN_MAPOR is the mapping from or source patterns
to their map of symbols to pattern variables. $PCTN_BINDLIST is the
binding list for input arguments in matcher. $PCTN_STUFFMAP is the
mapping from a matched stuff to the list of normaltesters matching
it. $PCTN_PVARLOCMAP maps pattern variable symbols to local
occurrences. $PCTN_TESTS is the list of normal
testers. $PCTN_VARHANDERS is a list of pattern variable handler when
scanning variables.}#
  :fields (pctn_normctxt		;the class_normalization_context
	   pctn_src			;the source match expression
	   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
	   ;; list of pattern variables handlers when scanning
	   pctn_varhandlers
	   ))

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



;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; catch-all for scanning any receiver (by failing)
(defun scanpat_anyrecv (recv psloc ctyp pcn)
  (debug "scanpat_anypattern recv" 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 receiver" ())
    ))
(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 "scanpat_anypattern recv" 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 "scanpat_anypattern myclass [discrim of recv]" myclass)
    (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 "scanpat_srcpatvar recv" 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 :spatvar_symb recv))
	 (mapvar (unsafe_get_field :pctn_mapatvar pcn))
	 (varhdlerlist (unsafe_get_field :pctn_varhandlers pcn))
	 (mvar (mapobject_get mapvar svar))
	 )
    (cond ( (null mvar)
	    (mapobject_put mapvar svar recv)
	    (debug "scanpat_srcpatvar return new svar" svar)
	    (setq mvar recv)
	    )
	  (:else
	   (debug "scanpat_srcpatvar return found mvar" mvar)
	   ))
    (assert_msg "check mvar" (is_a mvar class_source_pattern_variable))
    (let ( (nboccbox (unsafe_get_field :spatvar_nbocc mvar)) 
	   (:long nbocc (get_int nboccbox))
	   )
      (put_int nboccbox (+i nbocc 1)))
    (foreach_pair_component_in_list
     (varhdlerlist)
     (curpair curhdler)
     (if (is_closure curhdler)
	 (curhdler mvar pcn recv)))
    ))
(install_method class_source_pattern_variable scan_pattern scanpat_srcpatvar)

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;; scanning pattern joker
(defun scanpat_srcpatjoker (recv psloc ctyp pcn)
  (debug "scanpat_srcpatjoker recv" 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 a pattern constant
(defun scanpat_srcpatconstant (recv psloc ctyp pcn)
  (debug "scanpat_srcpatconst recv" 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 "scanpat_srcpatconstant nonobj literal const" sconst)
	(setq ncst sconst)
       )
     ( (null mcst)
       (multicall
	(nconst nbindconst)
	(normal_exp sconst env ncx sloc)
	(debug "scanpat_srcpatconstant nconst" nconst)
	(mapobject_put mapcst sconst nconst)
	(if nbindconst (list_append2list bindlist nbindconst))
	(setq ncst nconst)
	))
     (:else
      (debug "scanpat_srcpatconstant got mcst" mcst)
      ))
    (debug "scanpat_srcpatconstant ncst" ncst)
    (let ( (rectyp (get_ctype ncst env)) )
      (debug "scanpat_srcpatconstant rectyp" 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))
	     (warning_plain 
	      (get_field :loca_location (get_field :pctn_src pcn))
	      "perhaps this MATCH expression is badly parenthesised")
	     ))
      )))
(install_method class_source_pattern_constant scan_pattern scanpat_srcpatconstant)


;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;; scanning a pattern construct

(defun scanpat_srcpatconstruct (recv psloc ctyp pcn)
  (debug "scanpat_srcpatconstruct recv" recv)
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (assert_msg "check recv" (is_a recv class_source_pattern_construct))
  (let ( (sloc (unsafe_get_field :loca_location recv))
	 (subpa (unsafe_get_field :ctpat_subpa recv))
	 (ncx (unsafe_get_field :pctn_normctxt pcn))
	 )
    (assert_msg "check ctyp is value" (== ctyp ctype_value))
    (foreach_in_multiple 
     (subpa)
     (cursubpa :long subix)
     (debug "scanpat_srcpatconstruct before scan_pattern cursubpa=" cursubpa " subix=" subix)
     (scan_pattern cursubpa sloc ctype_value pcn)
     (debug "scanpat_srcpatconstruct after scan_pattern cursubpa=" cursubpa " subix=" subix)
     )
     (debug "scanpat_srcpatconstruct done subpa=" subpa)
  ))
(install_method class_source_pattern_construct scan_pattern scanpat_srcpatconstruct)



;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;; scanning a pattern object or instance
(defun scanpat_srcpatobject (recv psloc ctyp pcn)
  (debug "scanpat_srcpatobject recv" 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 "scanpat_srcpatobject end recv" 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 "scanpat_srcpatcomposite start recv=" recv " ctyp=" 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 "scanpat_srcpatcomposite soper" sop)
		  (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 "scanpat_srcpatcomposite matmb" mb)
		  (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 "scanpat_srcpatcomposite matout" 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 "scanpat_srcpatcomposite mismatched ctyp=" ctyp
		  " matctyp=" matctyp " mismatched recv=" recv)
	   ;;
	   (return)))
    (multicall 
     (nins bindins)
     (normalize_tuple sins env ncx sloc)
     (debug "scanpat_srcpatcomposite nins" nins)
     (if bindins (list_append2list bindlist bindins))
     (debug "scanpat_srcpatcomposite souts=" souts " matout=" matout)
     (foreach_in_multiple
      (souts)
      (pout :long ix)
      (debug "scanpat_srcpatcomposite before scan_pattern pout" pout)
      (let ( (curobind (multiple_nth matout ix)) 
	     (curctype (get_field :fbind_type curobind))
	     )
	(debug "scanpat_srcpatcomposite curobind=" curobind " curctype=" curctype)
	(assert_msg "check curctype" (is_a curctype class_ctype))
	(scan_pattern pout sloc curctype pcn)
	(debug "scanpat_srcpatcomposite after scan_pattern pout" pout)
	))
     (debug "scanpat_srcpatcomposite end recv" recv)
     )))
(install_method class_source_pattern_composite scan_pattern scanpat_srcpatcomposite)


;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;; scanning or pattern
(defun scanpat_srcpator (recv psloc ctyp pcn)
  (debug "scanpat_srcpator recv" recv)
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (assert_msg "check recv" (is_a recv class_source_pattern_or))
  (debug "scanpat_srcpator pcn start" pcn)
  (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))
	 (ownvarmap (make_mapobject discr_map_objects (+i 4 (*i cntpvarmap 2))))
	 (varhdlerlist (unsafe_get_field :pctn_varhandlers pcn))
	 (ownvarhandler
	  (lambda (mvar mypcn pvar)
	    (debug "scanpat_srcpator.ownvarhandler mvar" mvar)
	    (assert_msg "check mvar" (is_a mvar class_source_pattern_variable))
	    (assert_msg "check mypcn" (== mypcn pcn))
	    (let ( (msymb (unsafe_get_field :spatvar_symb mvar)) )
	      (mapobject_put ownvarmap msymb mvar))
	    ))
	 (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 "scanpat_srcpator sdisj" sdisj)
    (assert_msg "check sdisj" (is_multiple sdisj))
    (list_prepend varhdlerlist ownvarhandler)
    (foreach_in_multiple
     (sdisj)
     (dis :long ix)
     (debug "scanpat_srcpator dis" 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))))
	   (oldvarhdler (list_popfirst varhdlerlist))
	   )
      (assert_msg "check pmapor" (is_mapobject pmapor))
      (assert_msg "check oldvarhdler" (== oldvarhdler ownvarhandler))
      ;; 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 :spatvar_symb curpatvar) cursym))
       (if (null (mapobject_get inipvarmap cursym))
	   (mapobject_put orvarmap cursym curpatvar))
       )
      (debug "scanpat_srcpator orvarmap" orvarmap)
      (mapobject_put pmapor recv orvarmap)
      )
    (debug "scanpat_srcpator end pcn=" pcn " recv=" recv)
    ))
(install_method class_source_pattern_or scan_pattern scanpat_srcpator)




;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;; scanning and pattern
(defun scanpat_srcpatand (recv psloc ctyp pcn)
  (debug "scanpat_srcpatand recv=" recv "\n ctyp=" ctyp "\n pcn=" pcn)
  (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)
     (debug "scanpat_srcpatand dis=" dis "\n ix=" ix)
     (scan_pattern dis sloc ctyp pcn)
     )
    (debug "scanpat_srcpatand end recv=" recv)
    ))
(install_method class_source_pattern_and scan_pattern scanpat_srcpatand)

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

;;; selector to normalize a pattern
;;; receiver 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_norexp
	   norvar_locsym 
	   norvar_patvar		
	   norvar_nrepor
	   )
  :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.
  $NORVAR_NOREXP gives the normalized matched expression.}#
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; 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 failing end of disjuncts to clear a list of variables
(defclass class_normtester_or_clear
  :super class_normtester_any
  :fields (ntorclear_locsym    ;tuple of symbol occurrences to clear
	   ))

;; quasi-tester used at start of or to initialize & clear a list of variables
(defclass class_normtester_or_initial_clear
  :super class_normtester_or_clear
  :fields (
	   ))

;; quasi-tester used at succeeding end of disjuncts to transmit a list of variables
(defclass class_normtester_or_transmit
  :super class_normtester_any
  :fields (ntortransmit_dst		;tuple of locsymocc destinations
	   ntortransmit_src		;tuple of [normal] sources
))


;; 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
(compile_warning "we probably need to compute the ntdisj_setorvar field somewhere")
(defclass class_normtester_disjunction
  :super class_normtester_anytester
  :fields (ntdisjuncts			;the tuple of disjunct tests
	   ntdisj_freshorvar		;the tuple of fresh or variables
	   ntdisj_setorvar		;the tuple of already set or variables
	   )
)
;; 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
	     ))


;; test for tuples
(defclass class_normtester_tuple
    :super class_normtester_anytester
    :fields (
	     ;; a tuple similar to the class's fields
	     nttuple_components		;the tuple of components
	     ))

;;;;;;;;;;;;;;;;
(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 "register_new_normtester ntest=" ntest " pcn=" 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 "register_new_normtester updated stuffmap" 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 "put_tester_then curtester=" curtester " thentester=" 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 "put_tester_then curdisjtuple" curdisjtuple)
	(foreach_in_multiple 
	 (curdisjtuple)
	 (curdisj :long disjix)
	 (debug "put_tester_then curdisj=" curdisj)
	 (let ( (curcont (instance class_reference :referenced_value curdisj)) )
	 (debug "put_tester_then curcont start=" curcont)
	 (set_new_tester_last_then thentester curcont)
	 (debug "put_tester_then curcont done" curcont)
	 ))
      ))
  (debug "put_tester_then curtester done" curtester)
)

;; utility to set the newtester to the last of a ntest_then linked list
(defun set_new_tester_last_then (newtester testercont)
  (debug "set_new_tester_last_then newtester=" newtester " testercont=" 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_reference))
  (let ( (curtester (get_field :referenced_value testercont)) )
    (forever 
     lastesterloop
     (debug "set_new_tester_last_then loop curtester" 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 "set_new_tester_last_then final curtester" curtester)
    (assert_msg "check curtester set_new_tester_last_then" curtester)
    (put_fields testercont :referenced_value curtester)
    (put_tester_then curtester newtester)
    (debug "set_new_tester_last_then end testercont" 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 "set_new_tester_all_elses newtester=" newtester 
	 "\n.. partester" partester "\n.. updatlist=" updatlist)
  (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_any))
  (if (null updatlist) 
      (setq updatlist (make_list discr_list)))
  (assert_msg "check updatlist" (is_list updatlist))
  (forever
   allelseloop
   (debug "set_new_tester_all_elses allelseloop partester" 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 "set_new_tester_all_elses updated partester=" partester)
	 (list_append updatlist partester)
	 )
	(:else
	 (foreach_pair_component_in_list
	  (updatlist)
	  (curpair curtest)
	  (if (== curtest partester) 
	      (exit allelseloop))
	  (if (== curtest newtester)
	      (exit allelseloop))
	  )
	 (setq partester eltest))
	)
       (debug "set_new_tester_all_elses here partester=" partester
	      "\n thtest=" thtest)
       (cond ( (is_a thtest class_normtester_anytester)
	 (foreach_pair_component_in_list
	  (updatlist)
	  (curpair curtest)
	  (if (== curtest thtest) 
	      (exit allelseloop))
	  (if (== curtest newtester)
	      (exit allelseloop))
	  )
	 (debug "set_new_tester_all_elses before recursion" thtest)
	 (set_new_tester_all_elses newtester thtest updatlist)
	 (debug "set_new_tester_all_elses after recursion" thtest)
	 )))
     )
    (:else
     (exit allelseloop)))
   ) ;;;; end forever allelseloop
  (debug "set_new_tester_all_elses return updatlist" updatlist)
  (return updatlist)
  )
  


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

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; catch-all for normpat any receiver (by failing)
(defun normpat_anyrecv (recv nmatch hdler pcn)
  (debug "normpat_anyrecv recv" 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 "normpat_anyrecv recv" 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)))
	 )
    (debug "normpat_anyrecv myclass=" myclass " recv=" recv " nmatch=" nmatch)
    (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 "normvarpat_genreusetest tstuff" 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 "normvarpat_genreusetest lambda curhdler updatelse of tstuff=" 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 "normvarpat_genreusetest newtester same" newtester)
	 (setq tester newtester)
	 (list_append testlist newtester)
	 (curhdler newtester)
	 (exit loopstuff)
	 )
       )
      )
     )
    )
  )

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; normalize variable pattern
(defun normpat_variablepat (recv nmatch hdler pcn)
  (debug "normpat_variablepat recv=" recv " nmatch=" 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))
	 (pvarlocmap (get_field :pctn_pvarlocmap pcn)) 
	 (psloc (get_field :loca_location (get_field :pctn_src pcn)))
	 (sloc (get_field :loca_location recv))
	 (patvar (get_field :spatvar_symb recv))
	 (tstuff (mapobject_get stuffmap nmatch))
	 (lococc (mapobject_get pvarlocmap patvar))
	 (env (get_field :pctn_env pcn))
	 (ncx (get_field :pctn_normctxt pcn))
	 (testlist (get_field :pctn_tests pcn))
	 )
    (debug "normpat_variablepat tstuff=" tstuff " lococc=" lococc " patvar=" 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 "normpat_variablepat alreadybound lococc" lococc)
       (normvarpat_genreusetest sloc nmatch lococc testlist tstuff hdler pcn)
       )
     ;; process specially or variables
     ((is_a lococc class_normal_or_variable)
      (debug "normpat_variablepat lococc orvariable" lococc)
      (compile_warning "normpat_variablepat unhandled orvariable")
      (let ( (realococc (unsafe_get_field :norvar_locsym lococc)) 
	     (npatvar (unsafe_get_field :norvar_patvar lococc))
	     (patsym (get_field :spatvar_symb npatvar))
	     )
	(debug "normpat_variablepat orvariable npatvar" npatvar)
	(assert_msg "check patsym == patvar" (== patsym patvar))
	(debug "normpat_variablepat orvariable realococc" 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 "normpat_variablepat fresh orvariable clocc" clocc)
		  (put_fields lococc 
			      :norvar_locsym clocc
			      :norvar_norexp nmatch)
		  (debug "normpat_variablepat updated fresh orvariable lococc" lococc)
		  (shortbacktrace_dbg "normpat_variablepat updated fresh orvar" 15)
		  ;; put the clocc in the symbol cache map
		  (mapobject_put (get_field :nctx_symbcachemap ncx) patvar clocc)
		  (mapobject_put pvarlocmap patvar clocc)
		  (debug "normpat_variablepat updated fresh orvariable pvarlocmap" pvarlocmap)
		  )
		)
	      ;;
	      ;; the or-variable was already bound within the same
	      ;; disjunct, so generate or reuse a same test
	      ( (is_a realococc class_nrep_locsymocc)
		(debug "normpat_variablepat bound orvariable realococccc" realococc)
		(normvarpat_genreusetest sloc nmatch realococc testlist tstuff hdler pcn)
		)
	      ;; the or-variable was already bound in a previous
	      ;; disjunction
	      ( (is_a realococc class_reference)
		(let ( 
		      (ctyp (get_ctype nmatch env))
		      (bxclocc (deref realococc))
		      )
		  (debug "normpat_variablepat bxclocc" bxclocc)
		  (assert_msg "check bxclocc" (is_a bxclocc class_nrep_locsymocc))
		  ;; check ctype compatibility with former occurence
		  (let (
			 (prevctyp (unsafe_get_field :nocc_ctyp bxclocc))
			 )
		    (if (!= ctyp prevctyp)
			(let ( (prevsloc (unsafe_get_field :nrep_loc bxclocc)) 
			       )
			  (error_strv sloc "incompatible type for pattern variable inside OR pattern"
				      (get_field :named_name (unsafe_get_field :nocc_symb bxclocc)))
			  (inform_strv sloc "disjunct pattern variable occurs here with type"
				       (get_field :named_name (get_field :ctype_keyword ctyp)))
			  (inform_strv prevsloc "disjunct pattern variable occurs previously with type"
				       (get_field :named_name (get_field :ctype_keyword prevctyp)))
			  )))
		  (put_fields lococc 
			      :norvar_locsym bxclocc
			      :norvar_norexp nmatch)
		  (debug "normpat_variablepat updated reusing orvariable lococc" lococc)
		  (shortbacktrace_dbg "normpat_variablepat updated reused orvar" 15)
		))
	      ;; 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 "normpat_variablepat ctyp=" ctyp " clocc=" 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 pvarlocmap patvar clocc)
	(debug "normpat_variablepat updated patvar=" patvar " clocc=" clocc
	       " pvarlocmap=" pvarlocmap)
	)
      )
     (: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 "normpat_jokerpat recv=" recv" nmatch=" 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 instance pattern
(defun normpat_instancepat (recv nmatch hdler pcn)
  (debug "normpat_instancepat start recv=" recv " nmatch=" 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 "normpat_instancepat loop tstuff" 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 "normpat_instancepat lambda updatelse of tstuff=" 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 "normpat_instancepat newtester" newtester)
	 (register_new_normtester newtester pcn)
	 (setq tester newtester)
	 (list_append testlist newtester)
	 (debug "normpat_instancepat before calling curhdler" curhdler)
	 (curhdler tester)
	 (debug "normpat_instancepat after calling curhdler" curhdler)
	 (exit loopstuff)
	 )
       ))
     )
    (debug "normpat_instancepat tester=" tester "recv=" recv " patcla=" patcla)
    (let ( (testloccl (get_field :ntest_locclist tester)) 
	   (testercont (instance class_reference
				 :referenced_value tester
				 ))
	   (sortedpatfields
	    (multiple_sort 
	     patfields
	     (lambda (pf1 pf2)
	       (assert_msg "check pf1" (is_a pf1 class_source_field_pattern))
	       (assert_msg "check pf2" (is_a pf2 class_source_field_pattern))
	       (let ( (:long wpf1 (get_int (get_field :pat_weight 
						      (get_field :spaf_pattern pf1))))
		      (:long wpf2 (get_int (get_field :pat_weight 
						      (get_field :spaf_pattern pf2))))
		      )
		 (cond  ((==i wpf2 wpf2) 
			 (return '0 ()))
			((<i wpf1 wpf2) 
			 (return '1 ()))
			(:else 
			 (return '-1 ())))))
	     discr_multiple
	     )		       
	    )
	   )
      (debug "normpat_instancepat before loop testercont=" testercont " sortedpatfields=" sortedpatfields)
      (assert_msg "check testbindl" (is_list testloccl))
      (foreach_in_multiple
       (sortedpatfields)
       (curpatf :long patix)
       (debug "normpat_instancepat  in loop curpatf=" curpatf " testercont=" testercont)
       (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 "normpat_instancepat.subhdler newsubtester=" newsubtester
			"testercont=" testercont)
		 (shortbacktrace_dbg "normpat_instancepat.subhdler" 16)
		 (let ( (prevtester (get_field :referenced_value testercont)) )
		   (debug "normpat_instancepat.subhdler prevtester" prevtester)
		   (assert_msg "check prevtester" (is_a prevtester class_normtester_anytester))
		   (set_new_tester_last_then newsubtester testercont)
		   )
		 (debug "normpat_instancepat.subhdler end newsubtester" newsubtester)
		 ))
	      )
	 (debug "normpat_instancepat curfld" curfld)
	 (cond  ( (== curfldcla patcla) ())
		( (subclass_of patcla curfldcla) ())
		(:else (error_strv floc "bad field in instance pattern" (get_field :named_name curfld))))
	 (debug "normpat_instancepat before normal_pattern cursubpat" cursubpat)
	 (let ( (curloccl ())
		)
	   (debug "normpat_instancepat scanning testloccl" testloccl)
	   ;; try to find an existing local occurrence for the field
	   (foreach_pair_component_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 "normpat_instancepat got curloccl" 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
					))
		     )
		 (debug "normpat_instancepat newbind=" newbind 
			"\n* newlocc=" newlocc)
		 (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 "normpat_instancepat updated fieldlocs tester" tester)
		 (list_append testloccl newlocc)
		 (debug "normpat_instancepat made newlocc" newlocc)
		 (setq curloccl newlocc)
		 ))
	   (debug "normpat_instancepat before normal_pattern cursubpat" cursubpat)
	   (normal_pattern cursubpat curloccl subhdler pcn)
	   (debug "normpat_instancepat after normal_pattern cursubpat=" cursubpat 
		  " curpatf=" curpatf)
	   )
	 )))
    (debug "normpat_instancepat final tester" tester)
    )
  (debug "normpat_instancepat recv end" recv)
  )
(install_method class_source_pattern_instance normal_pattern normpat_instancepat)


(defclass class_tuple_component_pattern
  :super class_root
  :fields (tupcp_pattern		;the pattern for the component
	   tupcp_index			;the component index
	   ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; normalize a tuple pattern
(defun normpat_tuplepat  (recv nmatch hdler pcn)
  (debug "normpat_tuplepat recv=" recv "nmatch=" nmatch " pcn=" pcn)
  (assert_msg "check pcn" (is_a pcn class_pattern_context))
  (assert_msg "check recv" (is_a recv class_source_pattern_tuple))
  (let (
	(sloc (get_field :loca_location recv))
	(tupsubpa (get_field :ctpat_subpa recv))
	(:long nbcomp (multiple_length tupsubpa))
	(ncx (get_field :pctn_normctxt pcn))
	(stuffmap (get_field :pctn_stuffmap pcn))
	(tstuff (mapobject_get stuffmap nmatch))
	(curhdler hdler)
	(tester ())
	(testlist (get_field :pctn_tests pcn))
	)
    (debug "normpat_tuplepat tupsubpa=" tupsubpa " nbcomp=" nbcomp)
    ;; find the tester in the stuff
    (forever
     loopstuff
     (debug "normpat_tuplepat loop tstuff=" tstuff)
     (cond
      ( (and 
	 (is_a tstuff class_normtester_tuple)
	 (==i (multiple_length (get_field :nttuple_components tstuff)) nbcomp)
	 )
	(debug "normpat_tuplepat found tstuff=" tstuff)
	(setq tester tstuff)
	)
      ((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 "normpat_tuplepat lambda updatelse of tstuff=" tstuff)
	       (list_append (get_field :ntest_comefrom tester) tstuff)
	       ))
       )
      (:else
       (let ( (newcomplocs
	       (make_multiple discr_multiple nbcomp))
	      (newtester
	       (instance class_normtester_tuple
			 :nrep_loc sloc
			 :ntest_matched nmatch
			 :ntest_then ()
			 :ntest_else ()
			 :ntest_locclist (make_list discr_list)
			 :ntest_comefrom (make_list discr_list)
			 :nttuple_components newcomplocs
			 ))
	      )
	 (debug "normpat_tuplepat newtester=" newtester)
	 (register_new_normtester newtester pcn)
	 (setq tester newtester)
	 (list_append testlist newtester)
	 (debug "normpat_tuplepat before calling curhdler" curhdler)
	 (curhdler tester)
	 (debug "normpat_tuplepat after calling curhdler" curhdler)
	 (exit loopstuff)
	 )
       )
      )
     )					;end forever loopstuff
    ;;
    (debug "normpat_tuplepat tester=" tester
	   "\n recv=" recv "\n  tupsubpa=" tupsubpa)
    (let ( (testloccl (get_field :ntest_locclist tester)) 
	   (testercont (instance class_reference
				 :referenced_value tester
				 ))
	   (unsortedsubpa
	    (let (
		  (listsubpa (make_list discr_list))
		  )
	      (foreach_in_multiple
	       (tupsubpa)
	       (subpa :long subix)
	       ;; we need to skip the joker subpatterns
	       (if (is_not_a subpa class_source_pattern_joker_variable)
		   (list_append listsubpa
				(instance class_tuple_component_pattern
					  :tupcp_pattern subpa
					  :tupcp_index (make_integerbox discr_constant_integer subix)))))
	      (debug "normpat_tuplepat unsorted listsubpa=" listsubpa)
	      (list_to_multiple listsubpa discr_multiple)
	      ))
	   (sortedsubpa 
	    (multiple_sort
	     unsortedsubpa
	     (lambda (supa1 supa2)
	       (let ( (:long wp1 (get_int (get_field :pat_weight (get_field :tupcp_pattern supa1))))
		      (:long wp2 (get_int (get_field :pat_weight (get_field :tupcp_pattern supa2))))
		      )
		 (cond ((==i wp1 wp2) '0)
		       ((<i wp1 wp2) '1)
		       (:else '-1))))
	     discr_multiple))
	   )
      (debug "normpat_tuplepat testercont before loop testercont=" testercont 
	     "\n unsortedsubpa=" unsortedsubpa      
	     "\n sortedsubpa=" sortedsubpa)
      (assert_msg "check testbindl" (is_list testloccl))
      (foreach_in_multiple
       (sortedsubpa)
       (curtupat :long tupatix)
       (debug "normpat_tuplepat curtupat=" curtupat " tupatix=" tupatix)
       (assert_msg "check curtupat" (is_a curtupat class_tuple_component_pattern))
       (let ( (curpat (get_field :tupcp_pattern curtupat))
	      (:long patix (get_int (get_field :tupcp_index curtupat)))
	      (subhdler 
	       (lambda (newsubtester)
		 (debug "normpat_tuplepat.subhdler newsubtester=" newsubtester
			"testercont=" testercont)
		 (shortbacktrace_dbg "normpat_tuplepat.subhdler" 16)
		 (let ( (prevtester (get_field :referenced_value testercont)) )
		   (debug "normpat_tuplepat.subhdler prevtester" prevtester)
		   (assert_msg "check prevtester" (is_a prevtester class_normtester_anytester))
		   (set_new_tester_last_then newsubtester testercont)
		   )
		 (debug "normpat_tuplepat.subhdler end newsubtester" newsubtester)
		 ))
	      )
	 (debug "normpat_tuplepat curpat=" curpat " patix=" patix)
	 (let ( (curloccl ())
		)
	   (debug "normpat_tuplepat scanning testloccl" testloccl)
	   ;; try to find an existing local occurrence for the field
	   (foreach_pair_component_in_list 
	    (testloccl)
	    (testpair testlocsy)
	    (assert_msg "check testlocsy" (is_a testlocsy class_nrep_locsymocc))
	    (if (==i patix
		     (get_int (get_field :nunth_index (get_field :letbind_expr (get_field :nocc_bind testlocsy)))))
		(progn
		  (setq testpair ())	;to exist from foreach
		  (setq curloccl testlocsy)))
	    )
	   (debug "normpat_tuplepat got curloccl=" curloccl)
	   ;; if no local occurrence found, add a new one
	   (if (null curloccl)
	       (let ( 
		     (newsym (clone_symbol 'nthcomp))
		     (nunthexp (instance class_nrep_unsafe_nth_component
					 :nrep_loc sloc
					 :nunth_tuple nmatch
					 :nunth_index (make_integerbox discr_constant_integer patix)
					 ))
		     (newbind (instance class_normal_let_binding
					:binder newsym
					:letbind_type ctype_value
					:letbind_expr nunthexp
					:letbind_loc sloc))
		     (newlocc (instance class_nrep_locsymocc
					:nrep_loc sloc
					:nocc_ctyp ctype_value
					:nocc_symb newsym
					:nocc_bind newbind
					))
		     )
		 (debug "normpat_tuplepat newlocc=" newlocc
			"\n* newbind=" newbind)
		 (multiple_put_nth
		  (get_field :nttuple_components  tester)
		  patix
		  newlocc)
		 ;; 
		 ;; put the newlocc in the symbol cache map
		 (mapobject_put (get_field :nctx_symbcachemap ncx) newsym newlocc)
		 (debug "normpat_tuplepat updated components tester" tester)
		 (list_append testloccl newlocc)
		 (debug "normpat_tuplepat made newlocc" newlocc)
		 (setq curloccl newlocc)
		 ))
	   (debug "normpat_tuplepat before normal_pattern curpat=" curpat " curloccl=" curloccl)
	   (normal_pattern curpat curloccl subhdler pcn)
	   (debug "normpat_tuplepat after normal_pattern curpat=" curpat " patix=" patix)
	   )))
      (debug "normpat_tuplepat final tester" tester)
      (debug "normpat_tuplepat recv end" recv)
      )))
(install_method class_source_pattern_tuple normal_pattern normpat_tuplepat)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; normalize a conjunction [and of subpatterns]
(defun normpat_andpat (recv nmatch hdler pcn)
  (debug "normpat_andpat recv=" recv "nmatch=" nmatch " pcn=" pcn)
  (shortbacktrace_dbg "normpat_andpat" 15)
  (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_reference))
	(subhdler
	 (lambda (newtester) 
	   (debug "normpat_andpat.subhdler newtester=" newtester
		  " testercont=" testercont)
	   (let ( (prevtester (get_field :referenced_value testercont)) )
	     (cond
	      ((is_a prevtester class_normtester_any)
	       (debug "normpat_andpat.subhdler prevtester" prevtester)
	       (set_new_tester_last_then newtester testercont)
	       )
	      (:else
	       (debug "normpat_andpat.subhdler before calling hdler newtester=" newtester)
	       (hdler newtester)
	       (put_fields testercont :referenced_value newtester)
	       (debug "normpat_andpat.subhdler after calling hdler newtester=" newtester)
	       ))
	     (debug "normpat_andpat.subhdler done testercont=" testercont)
	     )))
	)
    (foreach_in_multiple 
     (conjpats)
     (subpat :long subix)
     (debug "normpat_andpat  before normal_pattern testercont=" testercont 
	    "\n.. subpat=" subpat " subix=" subix "\n ..nmatch=" nmatch)
     (normal_pattern subpat nmatch subhdler pcn)
     (debug "normpat_andpat after normal_pattern subpat=" subpat
	    " testercont=" testercont)
     )
    (debug "normpat_andpat  end recv=" recv " testercont=" testercont)
    ))
(install_method class_source_pattern_and normal_pattern normpat_andpat)




;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; normalize a disjunction [or of subpatterns]

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

(defun normpat_orpat (recv nmatch hdler pcn)
  (debug "normpat_orpat recv=" recv " nmatch=" nmatch " pcn=" pcn)
  (shortbacktrace_dbg "normpat_orpat called" 16)
  (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))
	(testlist (get_field :pctn_tests pcn))
	(subtestlist (make_list discr_list)) ;; the list of subtests
	(stuffmap (get_field :pctn_stuffmap pcn))
	(pvarlocmap (get_field :pctn_pvarlocmap pcn)) 
	(mapor (get_field :pctn_mapor pcn))
	(ncx (get_field :pctn_normctxt pcn))
	(orvarmap (mapobject_get mapor recv)) 
	(sortedorsymbs (mapobject_sorted_attribute_tuple orvarmap))
	(disjtester (instance class_normtester_disjunction 
			      :nrep_loc sloc
			      :ntest_matched nmatch
			      :ntest_then ()
			      :ntest_else ()
			      :ntest_comefrom (make_list discr_list)
			      :ntdisjuncts ()
			      :ntdisj_freshorvar ()
			      :ntdisj_setorvar ()
			      )) 
	(sortorvars 
	 (multiple_map 
	  sortedorsymbs
	  (lambda (orsymb :long orix)
	    (let (
		  (curvarpat (mapobject_get orvarmap orsymb))
		  (curorvar (instance class_normal_or_variable
				      :norvar_patvar curvarpat
				      :norvar_nrepor disjtester
				      :norvar_norexp ()
				      :norvar_locsym ())
			    )
		  )
	      (assert_msg "check curvarpat"
			  (is_a curvarpat class_source_pattern_variable))
	      (put_int curorvar orix)
	      (debug "normpat_orpat/sortlambda curorvar=" curorvar 
		     " curvarpat=" curvarpat " orsymb=" orsymb)
	      (mapobject_put pvarlocmap orsymb curorvar)
	      (debug "normpat_orpat/sortlambda updated pvarlocmap" pvarlocmap)
	      (return curorvar)
	      ))
	  ))
	(prevcont (instance class_reference
			    :referenced_value disjtester))
	)
    (debug "normpat_orpat orig stuffmap=" stuffmap " pvarlocmap=" pvarlocmap
	   " orvarmap=" orvarmap)
    (assert_msg "check orvarmap" (is_mapobject orvarmap))
    (debug "normpat_orpat sortedorsymbs=" sortedorsymbs " sortorvars=" sortorvars
	   " disjtester=" disjtester)
    ;; first register and handle the empty disjtester
    (register_new_normtester disjtester pcn)
    (hdler disjtester)
    (list_append testlist disjtester)
    (debug "normpat_orpat handled disjtester" disjtester)
;;;;;;;;;;;;;;;;
;;;; foreach disjunctive subpattern
    (foreach_in_multiple
     (disjpats)
     (curdisj :long disjix)
     (let ( (clearloclist (make_list discr_list))
	    )
       (foreach_in_multiple
	(sortorvars)
	(curorvar :long orvix)
	(assert_msg "check curorvar" (is_a curorvar class_normal_or_variable))
	(let ( (orvarlocc (unsafe_get_field :norvar_locsym curorvar))
	       )
	  (if (is_a orvarlocc class_nrep_locsymocc)
	      (let ( (orvarcont (reference orvarlocc)) )
		(put_fields curorvar :norvar_locsym orvarcont)
		(list_append clearloclist orvarlocc)
		))
	  ))
       (let (
	     (norclear (instance class_normtester_or_clear
				 :nrep_loc sloc
				 :ntest_matched nmatch
				 :ntest_then ()
				 :ntest_else ()
				 :ntest_comefrom (make_list discr_list)
				 :ntorclear_locsym (list_to_multiple clearloclist discr_multiple)
				 ))
	     )
;;;;;;;;;;;;;;;;
	 ;; normalize the current disjunct
	 (debug "normpat_orpat curdisj before normalization" curdisj)
	 ;; add the norclear
	 (let (
	       (prevtest (get_field :referenced_value prevcont))
	       (prevloc (get_field :nrep_loc prevtest))
	       )
	   (debug "normpat_orpat prevtest=" prevtest " norclear=" norclear)
	   (list_append testlist norclear)
	   (debug "normpat_orclear setallelses norclear=" norclear " prevtest=" prevtest)
	   (set_new_tester_all_elses norclear prevtest)
	   (put_fields prevcont :referenced_value norclear)
	   (debug "normpat_orpat prevcont with norclear" prevcont)
	   ;;
	   (let (
		 (subdisjcont (reference ()))
		 (subdisjhandler 
		  (lambda (subtester)
		    (debug "normpat_orpat.lambda subtester" subtester)
		    (set_ref subdisjcont subtester)
		    (let (
			  (prevtestsub (unsafe_get_field :referenced_value prevcont))
			  )
		      (list_append subtestlist subtester)
		      (debug "normpat_orpat.lambda setlastthen subtester=" subtester
			     " prevcont=" prevcont)
		      (set_new_tester_last_then subtester prevcont)
		      (debug "normpat_orpat.lambda done subtester" subtester)
		      (put_fields prevcont :referenced_value subtester)
		      (debug "normpat_orpat prevcont with subtester" prevcont)
		      ))
		  )
		 )
	     (normal_pattern curdisj nmatch 
			     subdisjhandler pcn)       
	     (debug "normpat_orpat curdisj after normalization" curdisj)
	     (let (
		   (lastdisj (deref subdisjcont))
		   (prevtestrans (unsafe_get_field :referenced_value prevcont))
		   (nortransm (instance class_normtester_or_transmit
					:nrep_loc sloc
					:ntest_matched nmatch
					:ntest_then ()
					:ntest_else ()
					:ntest_comefrom (make_list discr_list)
					:ntortransmit_dst ()
					:ntortransmit_src ()
					))
		   )
	       (debug "normpat_orpat prevtestrans" prevtestrans)
	       (list_append testlist nortransm)
	       (debug "normpat_orpat setlasthen nortransm=" nortransm" prevcont=" prevcont)
	       (set_new_tester_last_then nortransm prevcont)
	       ;; if no proper disjunct test was generated, add the
	       ;; ortransmit to the list of tests, so that distributing
	       ;; the then thru the disjunct still works!
	       (if (null lastdisj)
		   (list_append subtestlist nortransm))
	       )
	     )
	   )
	 (debug "normpat_orpat done curdisj" curdisj)
	 )
       )
     )
    ;;
    (debug "normpat_orpat pvarlocmap before freshorvar" pvarlocmap)
    (debug "normpat_orpat final subtestlist" subtestlist)
    (let ( (freshorvar
	    (multiple_map
	     sortorvars
	     (lambda (curorvar :long orix)
	       (assert_msg "check curorvar" (is_a curorvar class_normal_or_variable))
	       (let ( (orlocsy (unsafe_get_field :norvar_locsym curorvar))
		      (patvar (unsafe_get_field :norvar_patvar curorvar))
		      (orsymb (get_field :spatvar_symb patvar))
		      )
		 (if (is_a orlocsy class_reference)
		     (setq orlocsy (deref orlocsy)))
		 ;; the pvarlocmap should already have orsymb bound to orlocsy
		 (debug "normpat_orpat/finalambda orsymb=" orsymb " orlocsy=" orlocsy)
		 (return orlocsy))
	       ))
	    )
	   )
      (debug "normpat_orpat final freshorvar" freshorvar)
      (put_fields disjtester 
		  :ntdisjuncts (list_to_multiple subtestlist discr_multiple)
		  :ntdisj_freshorvar freshorvar
		  )
      (debug "normpat_orpat final disjtester" disjtester)
      )
    ;;
    (compile_warning "@$@unimplemented normpat_orpat")
    (debug "enf normpat_orpat recv" recv)
    ))

(install_method class_source_pattern_or normal_pattern normpat_orpat)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; normalize anymatcher pattern
(defun normpat_anymatchpat (recv nmatch hdler pcn)
  (debug "normpat_anymatchpat recv=" recv
	 " nmatch=" nmatch " pcn=" 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 "normpat_anymatchpat inargs=" inargs
	   " mat=" mat   " matopbind=" matopbind)
    (let ( 
	  (matvar (let ( (mv (get_field :binder matopbind)) )
		    (debug "normpat_anymatchpat matvar" mv)
		    (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 "normpat_anymatchpat matndata" matndata)
      (multicall
       (nins bindins)
       (normalize_tuple inargs env ncx sloc)
       (debug "normpat_anymatchpat nins=" nins " bindins=" 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 "normpat_anymatchpat inargs=" inargs "inmatchs=" 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 "normpat_anymatchpat ncurin" ncurin)
		  (let ( (curmatch (multiple_nth inmatchs ix)) 
			 (curctype (get_ctype ncurin env))
			 (matchtype (get_field :fbind_type curmatch))
			 )
		    (debug "normpat_anymatchpat curmatch" curmatch)
		    (assert_msg "check curmatch" 
				(is_a curmatch class_formal_binding))
		    (debug "normpat_anymatchpat curctype=" curctype " matchtype=" 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 "normpat_anymatchpat newb=" newb)
			(put_env newenv newb)
			))))
		 (setq env newenv)
		 (put_fields pcn :pctn_env newenv)
		 )))
	 ;; output args
	 (debug "normpat_anymatchpat outargs=" outargs " outmatchs=" 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 "normpat_anymatchpat tstuff" 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 "normpat_anymatchpat good tstuff" 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 "normpat_anymatchpat lambda updatelse of tstuff" 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 "normpat_anymatchpat updatelse tsuff" tstuff)
			(list_append (get_field :ntest_comefrom tester) tstuff)
			))
		)
	       (:else
		(let
		    ( (outlocs
		       (multiple_map 
			outmatchs
			(lambda (curoutmatch :long ix)
			  (debug "normpat_anymatchpat curoutmatch" 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)
			    (debug "normpat_anymatchpat clocc=" 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 "normpat_anymatchpat newtester" 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 "normpat_anymatchpat got tester" tester)
	 (assert_msg "check tester" (is_a tester class_normtester_matcher))
	 ;;	
	 (let ( (outlocs (get_field :ntmatch_outlocs tester)) )
	   (debug "normpat_anymatchpatfrom tester outlocs=" outlocs
		  " outargs=" outargs  " outmatchs=" outmatchs)
	   (foreach_in_multiple
	    (outmatchs)
	    (curmatch :long ixm)
	    (messagenum_dbg "normpat_anymatchpat ixm in outmatchs" ixm)
	    (debug "normpat_anymatchpat curmatch in foreach" curmatch)
	    (let ( (clocc (multiple_nth outlocs ixm)) 
		   (curout (multiple_nth outargs ixm))
		   (testercont (instance class_reference
					 :referenced_value tester))
		   (subhdler 
		    ;; put the new tester as the last element of its
		    ;; ntest_then chain
		    (lambda (newtester)
		      (debug "normpat_anymatchpat subhdler newtester" newtester)
		      (shortbacktrace_dbg "normpat_anymatchpat subhdler" 14)
		      (set_new_tester_last_then newtester testercont)
		      ))
		   )
	      (debug "normpat_anymatchpat before normal_pattern curout=" curout " clocc=" clocc)
	      (shortbacktrace_dbg "normpat_anymatchpat before normal_pattern curout" 14)
	      (normal_pattern curout clocc subhdler pcn)
	      (debug "normpat_anymatchpat curout after normal_pattern" curmatch)
	      )
	    )
	   )
	 (debug "normpat_anymatchpat outbinds" 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 "normpat_constpat recv=" recv " nmatch=" nmatch  " pcn=" 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))
	(pvarlocmap (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 "normpat_constpat tstuff" tstuff)
    (let (
	  (tester ())
	  (curhdler hdler)
	  (nconst (if (is_object sconst) (mapobject_get mapcst sconst) sconst))
	  )
      (debug "normpat_constpat nconst" nconst)
      (forever 
       loopstuff
       (debug "normpat_constpat tstuff" 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 "normpat_constpat lambda updatelse tstuff=" 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 "normpat_constpat newtester same" newtester)
	   (setq tester newtester)
	   (list_append testlist newtester)
	   (curhdler newtester)
	   (exit loopstuff)
	   )
	 )
	)
       )				;end forever
      (debug "normpat_constpat got tester" tester)
      )
    )
  )
(install_method class_source_pattern_constant normal_pattern normpat_constpat)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; to ease debugging, we offer the option to generate .dot files
;;;;; for graphviz (see http://www.graphviz.org/ for more)

;;  the instance containing the string value prefix of the generated
;;  .dot file, should be something like /tmp/mygr to generated
;;  /tmp/mygr1.dot /tmp/mygr2.dot etc...
(definstance match_graphic_dot_prefix class_reference
  :referenced_value ())

		 

;;; a private class to help generate dot graphics
(defclass class_match_graphic
  :doc #{$CLASS_MATCH_GRAPHIC is a private class to generate graphviz
  .dot graphics files to debug the MELT translation of matching. Don't
  use it yourself.}#
  :super class_proped
  :fields (
	   mchgx_filename		;the filename
	   mchgx_nodout			;the output strbuf for nodes
	   mchgx_edgout			;the output strbuf for edges
	   mchgx_datanamemap		;the objmap for name of datas
	   mchgx_stepnamemap		;the objmap for name of steps
	   ))

;; internal function to out the node name for the match graphic
(defun mg_out_node_name (out ntest)
  (assert_msg "check out" (is_out out))
  (assert_msg "check ntest" (is_a ntest class_normtester_any))
  (let ( (cla (discrim ntest))
	 (clanam (get_field :named_name cla))
	 (:long clanamlen (string_length clanam))
	 (:long ix (get_int ntest))
	)
    ;; the classname starts with CLASS_ which has six characters, we
    ;; skip them for the node name
    (assert_msg "check clanamlen" (>i clanamlen 6))
    (code_chunk outchunk
		#{ /* mg_node_name $OUTCHUNK */
		meltgc_add_out ((melt_ptr_t) $OUT,
				melt_string_str ((melt_ptr_t) $CLANAM) +6);
		meltgc_out_printf ((melt_ptr_t) $OUT, "_%d",
				   (int) $IX);
		}#
		)
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; internal selector to output the label of a test in "HTML-like"
;; graphiz format
(defselector matchgraphic_label class_selector
)
(defun mglabel_any (recv mg)
  (let ( (dis (discrim recv))
	 (disname (get_field :named_name dis))
	 )
  (debug "mglabel_any recv=" recv " mg=" mg " dis=" dis)
  (errormsg_strv "unimplemented MATCHGRAPHIC_LABEL for " disname)
  (assert_msg "@$@unexpected mglabel_anyobj")
))
(install_method discr_any_receiver matchgraphic_label mglabel_any)
  
(defun mglabel_any_test (ntest mg)
  (debug "mglabel_any_test start ntest" ntest)
  (assert_msg "check ntest" (is_a ntest class_normtester_any))
  (assert_msg "check mg" (is_a mg class_match_graphic))
  (let ( (nloc (unsafe_get_field :nrep_loc ntest))
	 (nmatched (unsafe_get_field :ntest_matched ntest))
	 (nodout (unsafe_get_field :mchgx_nodout mg))
	 (edgout (unsafe_get_field :mchgx_edgout mg))
	 )
    (debug "mglabel_any_test nloc=" nloc " nmatched=" nmatched)
    (assert_msg "check nodout" (is_out nodout))
    (assert_msg "check edgout" (is_out edgout))
    ;; first table row: output the node name in blue bold and the hashcode
    (add2out_strconst nodout "<tr><td>")
    (add2out_strconst nodout 
		      "<font color=\"blue\" face=\"Times-Roman Bold\" point-size=\"10\">")
    (mg_out_node_name nodout ntest)
    (add2out_strconst nodout "</font></td> ")
    (add2out_strconst nodout "<td><font face=\"Courier\" point-size=\"8\">#")
    (add2out_longhex nodout (obj_hash ntest))
    (add2out_strconst nodout "</font></td> ")
    (add2out_strconst nodout "</tr>")
    (add2out_indentnl nodout 2)
    ;; if we have a location, it makes a row
    (cond
     ( (is_mixloc nloc)
       (add2out_strconst nodout "<tr><td rowspan=\"2\">")
       (add2out_strconst nodout "<font face=\"Courier Italic\" point-size=\"8\">")
       (add2out_mixloc nodout nloc)
       (add2out_strconst nodout "</font></td> </tr>")
       (add2out_indentnl nodout 2)
       )
     )
    ;; if the matched is a locsymocc [it usually should] display it,
    ;; that is its symbol and the hashcode of the locsymocc
    (if (is_a nmatched class_nrep_locsymocc)
	(let ( (nmaloc (unsafe_get_field :nrep_loc nmatched))
	       (nmasymb (unsafe_get_field :nocc_symb nmatched))
	       (:long nmarank
		      (get_int (get_field :csym_urank nmasymb)))
	       )
	  (add2out_strconst nodout "<tr><td>")
	  (add2out_strconst nodout "<font face=\"Courier Bold\" point-size=\"8\">")
	  (add2out_string nodout (get_field :named_name nmasymb))
	  (if (>i nmarank 0)
	      (progn
		(add2out_strconst nodout " #")
		(add2out_longhex nodout nmarank)
		(add2out_strconst nodout " ")
		))
	  (add2out_strconst nodout "</font></td>  <td><font point-size=\"8\">##")
	  (add2out_longhex nodout (obj_hash nmatched))
	  (add2out_strconst nodout "</font></td> </tr>")
	  (add2out_indentnl nodout 2)
	  ))
    (debug "mglabel_any_test end ntest" ntest)
    ))
(install_method class_normtester_any matchgraphic_label mglabel_any_test)

;; output an instance test
(defun mglabel_instance_test (ntest mg)
  (debug "mglabel_instance_test start ntest" ntest)
  (assert_msg "check ntest" (is_a ntest class_normtester_instance))
  (assert_msg "check mg" (is_a mg class_match_graphic))
  (let ( (nloc (unsafe_get_field :nrep_loc ntest))
	 (nmatched (unsafe_get_field :ntest_matched ntest))
	 (nodout (unsafe_get_field :mchgx_nodout mg))
	 (edgout (unsafe_get_field :mchgx_edgout mg))
	 )
    (debug "mglabel_instance_test nloc=" nloc "nmatched=" nmatched)
    (assert_msg "check nodout" (is_out nodout))
    (assert_msg "check edgout" (is_out edgout))
    ;; first table row: output the node name in blue bold and the hashcode and the tested class
    (add2out_strconst nodout "<tr><td>")
    (add2out_strconst nodout 
		      "<font color=\"violet\" face=\"Times-Roman Bold\" point-size=\"10\">")
    (mg_out_node_name nodout ntest)
    (add2out_strconst nodout "</font></td> ")
    (add2out_strconst nodout "<td><font face=\"Courier\" point-size=\"8\">#")
    (add2out_longhex nodout (obj_hash ntest))
    (add2out_strconst nodout "</font></td> ")
    (add2out_strconst nodout "<td><font face=\"Courier Italic\" point-size=\"8\">")
    (add2out_string nodout (get_field :named_name
				      (get_field :nocc_symb 
						 (get_field :ntinst_class ntest))))
    (add2out_strconst nodout "</font></td> ")
    (add2out_strconst nodout "</tr>")
    (add2out_indentnl nodout 2)
    ;; if we have a location, it makes a row
    (cond
     ( (is_mixloc nloc)
       (add2out_strconst nodout "<tr><td rowspan=\"2\">")
       (add2out_strconst nodout "<font face=\"Courier Italic\" point-size=\"8\">")
       (add2out_mixloc nodout nloc)
       (add2out_strconst nodout "</font></td> </tr>")
       (add2out_indentnl nodout 2)
       )
     )
    ;; if the matched is a locsymocc [it usually should] display it,
    ;; that is its symbol and the hashcode of the locsymocc
    (if (is_a nmatched class_nrep_locsymocc)
	(let ( (nmaloc (unsafe_get_field :nrep_loc nmatched))
	       (nmasymb (unsafe_get_field :nocc_symb nmatched))
	       (:long nmarank
		      (get_int (get_field :csym_urank nmasymb)))
	       )
	  (add2out_strconst nodout "<tr><td>")
	  (add2out_strconst nodout "<font face=\"Courier Bold\" point-size=\"8\">")
	  (add2out_string nodout (get_field :named_name nmasymb))
	  (if (>i nmarank 0)
	      (progn
		(add2out_strconst nodout " #")
		(add2out_longhex nodout nmarank)
		(add2out_strconst nodout " ")
		))
	  (add2out_strconst nodout "</font></td>  <td><font point-size=\"8\">##")
	  (add2out_longhex nodout (obj_hash nmatched))
	  (add2out_strconst nodout "</font></td> </tr>")
	  (add2out_indentnl nodout 2)
	  ))
    (debug "mglabel_instance_test end ntest" ntest)
    ))
(install_method class_normtester_instance matchgraphic_label mglabel_instance_test)

;;; output a success test
(defun mglabel_success_test (ntest mg)
  (debug "mglabel_success_test start ntest" ntest)
  (assert_msg "check ntest" (is_a ntest class_normtester_success))
  (assert_msg "check mg" (is_a mg class_match_graphic))
  (let ( (nloc (unsafe_get_field :nrep_loc ntest))
	 (nmatched (unsafe_get_field :ntest_matched ntest))
	 (nodout (unsafe_get_field :mchgx_nodout mg))
	 (edgout (unsafe_get_field :mchgx_edgout mg))
	 )
    (debug "mglabel_success_test nloc=" nloc " nmatched=" nmatched)
    (assert_msg "check nodout" (is_out nodout))
    (assert_msg "check edgout" (is_out edgout))
    ;; first table row: output the node name and the hashcode
    (add2out_strconst nodout "<tr><td>")
    (add2out_strconst nodout 
		      "<font color=\"sienna\" face=\"Times-Roman Bold\" point-size=\"10\">")
    (mg_out_node_name nodout ntest)
    (add2out_strconst nodout "</font></td> ")
    (add2out_strconst nodout "<td><font face=\"Courier\" point-size=\"8\">#")
    (add2out_longhex nodout (obj_hash ntest))
    (add2out_strconst nodout "</font></td> ")
    (add2out_strconst nodout "</tr>")
    (add2out_indentnl nodout 2)
    ;; if we have a location, it makes a row
    (cond
     ( (is_mixloc nloc)
       (add2out_strconst nodout "<tr><td rowspan=\"2\">")
       (add2out_strconst nodout "<font face=\"Courier Italic\" point-size=\"8\">")
       (add2out_mixloc nodout nloc)
       (add2out_strconst nodout "</font></td> </tr>")
       (add2out_indentnl nodout 2)
       )
     )
    (debug "mglabel_success_test end ntest" ntest)
    ))
(install_method class_normtester_success matchgraphic_label mglabel_success_test)



;; internal function to out a tuple of test nodes in graphiz format
(defun matchgraphic_tests (testup mg)
  (debug "matchgraphic_tests  start testup=" testup " mg=" mg)
  (assert_msg "check testup" (is_multiple testup))
  (assert_msg "check mg" (is_a mg class_match_graphic))
  (let ( (nodout (unsafe_get_field :mchgx_nodout mg))
	 (edgout (unsafe_get_field :mchgx_edgout mg))
	 )
    (add2out_indentnl nodout 0)
    (add2out_indentnl edgout 0)
    (foreach_in_multiple 
     testup
     (curtest :long tix)
     (assert_msg "check curtest" (is_a curtest class_normtester_any))
     (debug "matchgraphic_tests curtest" curtest)
     ;; output the node and its label
     (mg_out_node_name nodout curtest)
     (add2out_strconst nodout " [ label=<")
     (add2out_strconst nodout "<table border=\"1\" cellborder=\"1\" cellspacing=\"1\" cellpadding=\"1\">")
     (add2out_indentnl nodout 1)
     (matchgraphic_label curtest mg)
     (add2out_indentnl nodout 1)
     (add2out_strconst nodout "</table>")
     (add2out_strconst nodout ">, margin=0")
     (if (==i tix 0)
	 (add2out_strconst nodout ", style=\"bold\"")) 
     (add2out_strconst nodout " ];")
     (add2out_indentnl nodout 0)
     ;; output the outgoing edges 
     (let ( (nthen (unsafe_get_field :ntest_then curtest))
	    (nelse (unsafe_get_field :ntest_else curtest))
	    )
       (if (is_a nthen class_normtester_any)
	   (progn
	     (mg_out_node_name edgout curtest)
	     (add2out_strconst edgout " -> /*then*/ ")
	     (mg_out_node_name edgout nthen)
	     (add2out_strconst edgout " [ arrowhead=normal, color=green ];")
	     (add2out_indentnl edgout 0)
	     ))
       (if (is_a nelse class_normtester_any)
	   (progn
	     (mg_out_node_name edgout curtest)
	     (add2out_strconst edgout " -> /*else*/ ")
	     (mg_out_node_name edgout nelse)
	     (add2out_strconst edgout " [ arrowhead=diamond, color=red ];")
	     (add2out_indentnl edgout 0)
	     ))
       )
     )
    ))


;; utility to out a graphviz .dot file for the tests inside match
(defun mg_draw_match_graphviz_file (nmatch dotprefix teststupl)
  (let (
        (:long hcodnmatch (obj_hash nmatch))
        (:long cnt 0)
        (:long nbtests (multiple_length teststupl)) 
        (pathsbuf (make_strbuf discr_strbuf)) 
        (dotfilename
         (progn
           (code_chunk 
            uniqcnt 
            #{  /* mg_draw_match_graphviz_file $UNIQCNT */ {
            static long uniqcounter;
            uniqcounter ++;
            $CNT = uniqcounter; }
            }#)
           (assert_msg "check pathsbuf" (is_strbuf pathsbuf))
           (add2sbuf_string pathsbuf dotprefix)
           (add2sbuf_longdec pathsbuf cnt)
           (add2sbuf_strconst pathsbuf ".dot")
           (debug "mg_draw_match_graphviz_file pathsbuf" pathsbuf)
           (strbuf2string discr_string pathsbuf)))
        (nodbuf (make_strbuf discr_strbuf))
        (edgbuf (make_strbuf discr_strbuf))
        (mg (instance class_match_graphic
                      :mchgx_filename dotfilename
                      :mchgx_nodout nodbuf
                      :mchgx_edgout edgbuf
                      ))
        )
    (debug "mg_draw_match_graphviz_file initial mg" mg)
    (matchgraphic_tests teststupl mg)
    (debug "mg_draw_match_graphviz_file final mg" mg)
    (assert_msg "check dotfilename" (is_string dotfilename))
    (code_chunk  outputmg
     #{ /* mg_draw_match_graphviz_file $OUTPUTMG */ {
     time_t nowt = 0;
     char nowbuf[60];
     FILE* dotfil = 
     fopen (melt_string_str ((melt_ptr_t) $DOTFILENAME), "w");
     if (!dotfil) 
       melt_fatal_error ("failed to open matchdot file %s - %m", 
			 melt_string_str ((melt_ptr_t) $DOTFILENAME));
     fprintf (dotfil, "// melt matchdot file %s\n", 
                      melt_string_str ((melt_ptr_t) $DOTFILENAME));
     time (&nowt);
     memset (nowbuf, 0, sizeof(nowbuf));
     strftime (nowbuf, sizeof(nowbuf)-1,
                       "%Y %b %d %Hh%M",
                       localtime (&nowt));
     fprintf (dotfil, "// generated %s\n", nowbuf);
     fprintf (dotfil, "digraph meltmatch_%lx {\n",
                      $HCODNMATCH);
     fprintf (dotfil, " graph [ label=\"Melt Match %d #%#lx %s\", pad=\"0.5\", margin=\"0.3\" ];\n",
                      (int) $CNT, $HCODNMATCH, nowbuf);
     fprintf (dotfil, " node [ shape=\"box\", fontsize=\"12\" ];\n");
     fprintf (dotfil, "// %d tests\n", (int) $NBTESTS);
     melt_putstrbuf (dotfil, (melt_ptr_t) $NODBUF);
     fprintf (dotfil, "\n /// edges\n");
     melt_putstrbuf (dotfil, (melt_ptr_t) $EDGBUF);
     fprintf (dotfil, "\n} // eof %s\n", melt_string_str ((melt_ptr_t) $DOTFILENAME));
     fclose (dotfil); } /* end mg_draw_match_graphviz_file $OUTPUTMG */
     }#)
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; 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 "normexp_match recv" 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
	 (cintsymb (clone_symbol 'match_inter_))
	 (nchint (instance class_nrep_checksignal
			   :nrep_loc sloc))
	 (cintbind (instance class_normal_let_binding
			     :binder cintsymb
			     :letbind_type ctype_void
			     :letbind_expr nchint))	 
	 )
    (debug "normexp_match smatsx=" smatsx " cintbind=" cintbind)
    (multicall
     (nmatx nbindmatx)
     (normal_exp smatsx env ncx sloc)
     (debug "normexp_match nmatx=" nmatx " nbindmatx=" nbindmatx " scases=" scases)
     (if (is_list nbindmatx)
	 (list_append nbindmatx cintbind)
       (setq nbindmatx (list cintbind)))
     ;;
     (let ( (ctyp (get_ctype nmatx env)) 
	    )
       (debug "normexp_match ctyp" 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))
	     (debug "normexp_match clocc=" clocc)
	     ;; put the clocc in the symbol cache map
	     (mapobject_put (get_field :nctx_symbcachemap ncx) csym clocc)
	     (setq nbindmatx (list 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 "normexp_match curcas" 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))
	      (pvarlocmap (make_mapobject discr_map_objects 23))
	      (varhdlerlist (make_list discr_list))
	      (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 pvarlocmap
			     :pctn_tests testlist
			     :pctn_varhandlers varhdlerlist
			     ))
	      (ntestcont (instance class_reference)) ;container for tester
	      )
	  (debug "normexp_match curpat before scan_pattern" curpat)
	  ;; 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 "normexp_match  after scan_pattern curpat=" curpat
		 " mapvar=" mapvar " pvarlocmap=" pvarlocmap
		 " mapcst=" mapcst)
	  (multiple_put_nth tupvarmap ix mapvar)
	  (multiple_put_nth tupcstmap ix mapcst)
	  (debug "normexp_match  before normal_pattern shabindlist=" shabindlist
		 " curpat=" curpat)
	  ;; normalize the current pattern, with the handler storing its topmost tester
	  (normal_pattern 
	   curpat nmatx
	   (lambda (tester) 
	     (debug "normexp_match.lambda tester" tester)
	     (shortbacktrace_dbg "normexp_match lambda tester" 12)
	     (assert_msg "check empty ntestcont" 
			 (null (unsafe_get_field :referenced_value ntestcont)))
	     (put_fields ntestcont :referenced_value tester))
	   pcn)
	  (debug "normexp_match  after normal_pattern curpat=" curpat
		 " pvarlocmap=" pvarlocmap
		 "ntestcont= " ntestcont
		 "shabindlist= " shabindlist)
	  ;; 
	  (let ( (newenv (get_field :pctn_env pcn))
		 (curtester (get_field :referenced_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 "normexp_match  after normal_pattern newenv=" newenv
		   " newsuctester=" newsuctester
		   " pvarlocmap=" pvarlocmap
		   " curcas=" curcas
		   " curtester=" curtester
		   " oldtester=" oldtester)
	    ;; 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 "normexp_match curcas for null curtester" curcas)
	      ;; 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 "normexp_match curestester set to success" curtester)
	      )
	     ;; 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_reference
					    :referenced_value curtester)) )
		(debug "normexp_match our curtestcont=" curtestcont
		       " newsuctester=" newsuctester)
		(set_new_tester_last_then newsuctester curtestcont)
		(debug "normexp_match final curtestcont" curtestcont)
		)
	      ) ;; end when null curtester
	     )	;; end cond
	    (debug "normexp_match final curtester" 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 "normexp_match initial oldtester" oldtester)
		  (set_new_tester_all_elses curtester oldtester)
		  (debug "normexp_match final oldtester" oldtester)
		  ))
	    ;; always set the oldtester to the curtester
	    (setq oldtester curtester)
	    (debug "normexp_match after lastesterloop pcn=" pcn
		   " pvarlocmap=" pvarlocmap)
	    (let ( (sortedvars (mapobject_sorted_attribute_tuple pvarlocmap)) 
		   (sortedbindings (make_multiple discr_multiple (multiple_length sortedvars)))
		   (freshnewenv (fresh_env newenv))
		   )
	      (debug "normexp_match sortedvars" sortedvars)
	      ;; we have to make a list of bindings based upon the sortedvars
	      (foreach_in_multiple
	       (sortedvars)
	       (svar :long svix)
	       (debug "normexp_match svar" svar)
	       (let ( (socc (mapobject_get pvarlocmap svar))
		      )
		 (debug "normexp_match socc" socc)
		 (assert_msg "check socc" (is_a socc class_nrep_locsymocc))
		 (let ( (sbind (unsafe_get_field :nocc_bind socc)) )
		   (debug "normexp_match sbind" sbind)
		   (multiple_put_nth sortedbindings svix sbind)
		   (put_env freshnewenv sbind)
		   )
		 ))
	      (debug "normexp_match freshnewenv=" freshnewenv
		     " sortedbindings=" sortedbindings)
	      (assert_msg "check sortedbindings" (is_multiple sortedbindings))
	      (let ( (subindlist (make_list discr_list)) 
		     )
		(foreach_in_multiple
		 (sortedbindings)
		 (cursortbind :long sortbix)
		 (debug "normexp_match cursortbind" cursortbind)
		 (assert_msg "check cursortbind" 
			     (is_a cursortbind class_normal_let_binding))
		 (list_append subindlist cursortbind)
		 )
		(debug "normexp_match curbody before normalize_tuple" curbody)
		(multicall 
		 (nbody bindsbody)
		 (normalize_tuple curbody freshnewenv ncx curloc)
		 (debug "normexp_match  after normalize_tuple curbody=" curbody
			" nbody=" nbody
			" bindsbody=" bindsbody)
		 (assert_msg "check bindsbody" (is_list_or_null bindsbody))
		 (foreach_pair_component_in_list
		  (bindsbody)
		  (bindbodypair curbindbody)
		  (debug "normexp_match curbindbody" curbindbody)
		  (list_append subindlist curbindbody)
		  )
		 (debug "normexp_match final subindlist" subindlist)
		 (let ( (wnlet (wrap_normal_letseq nbody subindlist curloc)) 
			(lastnbody (multiple_nth nbody -1))
			(lastctype (get_ctype lastnbody freshnewenv))
			)
		   (debug "normexp_match wnlet=" wnlet
			  " lastnbody=" lastnbody 
			  " lastctype=" 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 "normexp_match updated newsuctester" newsuctester)
		   ))))))) ;;; end foreach_in_multiple
       ;; end of loop on each case
       (debug "normexp_match tupvarmap=" tupvarmap
	      " tupcstmap=" tupcstmap
	      " testlist=" testlist
	      " stuffmap=" stuffmap
	      " stuffmapkeylist=" 
	      (let ( (stmpklist (make_list discr_list)) )
		(foreach_in_mapobject
		 (stuffmap)
		 (lococck litest)
		 (list_append stmpklist lococck)
		 )
		stmpklist))
       (let ( 
	     (teststupl (let ( (tt (list_to_multiple testlist discr_multiple)) )
			  (debug "normexp_match teststupl" tt)
			  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 "normexp_match csym=" csym "\n cbind=" cbind)
	 (put_fields clocc :nocc_bind cbind)
	 (debug "normexp_match clocc" 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 "normexp_match raw curtest" 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))
	  (put_int curtest tstix)
	  (debug "normexp_match testindex tstix=" tstix "\n* curtest=" curtest)
	  (put_fields curtest :ntest_normatch nmatch)
	  (debug "normexp_match indexed curtest" curtest)
	  )
	 (if (melt_need_dbg 1)
	     (let ( (dotprefix (get_field :referenced_value match_graphic_dot_prefix)) )
	       (debug "normexp_match match_graphic_dot_prefix=" match_graphic_dot_prefix
		      " dotprefix=" dotprefix)
	       (if (is_string dotprefix) 
		   (mg_draw_match_graphviz_file nmatch dotprefix teststupl
		 ))))
	 (unsafe_put_fields clocc :nocc_bind cbind)
	 (debug "normexp_match final teststupl=" teststupl " nbindmatx=" nbindmatx)
	 (assert_msg "check nbindmatx" (is_list nbindmatx))
	 (list_append nbindmatx cbind)
	 (debug "normexp_match final nmatch=" nmatch 
		" cbind=" cbind "returned nbindmatx=" nbindmatx
		" returned clocc=" clocc)
	 (return clocc nbindmatx)
	 )))))

;;;;
(install_method class_source_match normal_exp normexp_match)





;; for matchalt, alternate implementation of pattern matching
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; A L T E R N A T E     I M P L E M E N T A T I O N
;;;;                   O F 
;;;;  P A T T E R N  -  M A T C H I N G    
;;;;;;;;;;;;;;;;
(defclass class_matching_context
  :super class_root
  :doc #{The $CLASS_MATCHING_CONTEXT is a context for normalization of
pattern matching. $MCTX_NORMCTXT is the normalization
context. $MCTX_SOURCE is the source matching
expression. $MCTX_NMATCHED is the normal matched
expression. $MCTX_NMATBIND the corresponding bindings. $MCTX_CASES is
the tuple of cases each of $CLASS_MATCH_CASE. $MCTX_ENV is the
environment of the match. $MCTX_MDATA is the initial matched data of
$CLASS_MATCHED_DATA. $MCTX_VARHANDLERS is the list of pattern variable
handlers. $MCTX_FLAGS is the list of match flags.  $MCTX_ENDLABEL may
hold the ending label.}#
  :fields ( mctx_normctxt
	    mctx_source 
	    mctx_nmatched 
	    mctx_nmatbind
	    mctx_cases 
	    mctx_env 
	    mctx_mdata
	    mctx_varhandlers
	    mctx_flags
	    mctx_endlabel
	    ))

(defclass class_match_case
  :super class_proped
  :doc #{The $CLASS_MATCH_CASE describes a case match. Field
$MCASE_MCTXT is the matching context. $MCASE_SOURCE is the source
case, $MCASE_INDEX is the boxed integer rank. $MCASE_VARMAP is an
objectmap from symbols to the list of their pattern variables.}#
  :fields ( mcase_mctxt 
	    mcase_source 
	    mcase_index
	    mcase_varmap
	    ))

(defclass class_matched_data
  :super class_proped
  :doc #{The $CLASS_MATCHED_DATA describes some matched data. Field
$MDATA_SYMB gives the symbol, $MDATA_CTYPE gives the
ctype. $MDATA_ORIG is the origin step or data. $MDATA_STEPS is the
list of match steps, lazily transformed into a tuple when all steps
have been made.}#
  :fields ( mdata_symb
	    mdata_ctype
	    mdata_orig
	    mdata_steps
	    ))



(defclass class_matched_normal_data
  :super class_matched_data
  :doc #{The $CLASS_MATCHED_NORMAL_DATA is a sub-class for the initially matched normal data. The $MDATA_ORIG field is the normal matched thing.}#
  :fields (
	   ))

(defclass class_matched_binding
  :doc #{The $CLASS_MATCHED_BINDING is a binding for matched pattern
variables.  Field $MATCHBIND_DATA gives the matched data, and field
$MATCHBIND_NBOCC is the number of occurrences.}#
  :super class_any_binding
  :fields (matchbind_data
	   matchbind_nbocc
	   ))


;;;;;;;;;;;;;;;;
(defun normbind_matchbind (bind env ncx procs psloc)
  (assert_msg "check bind" (is_a bind class_matched_binding))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check ncx" (is_a ncx class_normalization_context))
  (debug "normbind_matchbind bind=" bind "\n ncx=" ncx)
  (shortbacktrace_dbg "normbind_matchbind" 18)
  (let ( (sycmap  (unsafe_get_field :nctx_symbcachemap ncx))
	 (symb (unsafe_get_field :binder bind))
	 (mdata (unsafe_get_field :matchbind_data bind))
	 (boxnbocc (unsafe_get_field :matchbind_nbocc bind))
	 (:long nbocc (get_int boxnbocc))
	 (syocc
		(instance class_nrep_locsymocc
			  :nrep_loc psloc
			  :nocc_ctyp (get_field :mdata_ctype mdata) 
			  :nocc_symb symb
			  ;; the bind is put here, but will be overwritten inside normstep_msuccwhenflag
			  :nocc_bind bind) ) 
	 )
    (debug "normbind_matchbind syocc=" syocc
	   "\n* mdata=" mdata "\n of discrim:" (discrim mdata))
    ;; increment the number of occurrences
    (put_int boxnbocc (+i nbocc 1))
    ;; cache the result & return it
    (mapobject_put sycmap symb syocc)
    (debug "normbind_matchbind updated sycmap=" sycmap
	   "\n for syocc=" syocc)
    syocc
    ))
(install_method class_matched_binding  normalize_binding normbind_matchbind)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass class_match_flag
  :super class_located
  :doc #{The $CLASS_MATCH_FLAG describes a flag related to a source
pattern. The $MFLAG_SPAT is the source pattern, and the $MFLAG_RANK is
a unique boxed integer rank, $MFLAG_STRING gives a small descriptive
string, The $MFLAG_SETSTEP is the match step setting that flag, or
else null. Match flags are initially cleared.}#
  :fields ( mflag_spat
	    mflag_rank
	    mflag_string
	    mflag_setstep
))

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


(defclass class_match_step
  :super class_located
  :doc #{The $CLASS_MATCH_STEP super-class describes an elementary step of pattern
matching, like tests, success, flag settings, etc... }#
  :fields ( ))

(defclass class_match_step_then
  :super class_match_step
  :doc #{The $CLASS_MATCH_STEP_THEN super-class is for steps with a
then edge $MSTEP_THEN.}#
  :fields (mstep_then))


(defclass class_match_step_clear
  :super class_match_step_then
  :doc #{The $CLASS_MATCH_STEP_CLEAR is a step to clear the $MSTEP_CLEARDATA tuple of matched data.}#
  :fields (mstep_cleardata))

(defclass class_match_step_with_flag
  :super class_match_step_then
  :doc #{The $CLASS_MATCH_STEP_WITH_FLAG super-class is for steps with a match
  flag $MSTEP_FLAG, in particular flag assignments and flagged successes.}#
  :fields (mstep_flag))

(defclass class_match_step_with_data
  :super class_match_step_then
  :doc #{The $CLASS_MATCH_STEP_WITH_DATA super-class is for matching
steps handling a data, such as matching tests. The inherited
$MSTEP_THEN gives the next step. The $MSTEP_DATA field is the matched
data. The $MSTEP_INDEX field is the boxed integer index counting from
1 of this step within its data, it is lazily filled when all steps of
the matched data have been made.}#
  :fields ( mstep_data
	    mstep_index 
	    ))

(defclass class_match_step_flag_set
  :super class_match_step_with_flag
  :doc #{The $CLASS_MATCH_STEP_FLAG_SET sets to true a match flag
$MSTEP_FLAG.}#
  :fields ())

(defclass class_match_step_flag_operation
  :super class_match_step_with_flag
  :doc #{The $CLASS_MATCH_STEP_FLAG_OPERATION sets the match flag according to flag arguments from the $MSTEP_FLAGARGS tuple.}#
  :fields (mstep_flagargs))

(defclass class_match_step_flag_conjunction
  :super class_match_step_flag_operation
  :doc #{The $CLASS_MATCH_STEP_FLAG_CONJUNCTION sets the match
flag $MSTEP_FLAG to the conjunction of $MSTEP_FLAGARGS, which is a
tuple of match flags.}#
  :fields ())

(defclass class_match_step_flag_disjunction
  :super class_match_step_flag_operation
  :doc #{The $CLASS_MATCH_STEP_FLAG_DISJUNCTION sets the match
flag $MSTEP_FLAG to the disjunction of $MSTEP_FLAGARGS, which is a
tuple of match flags.}#
  :fields ())


(defclass class_match_step_success_when_flag
  :super class_match_step_with_flag
  :doc #{The $CLASS_MATCH_STEP_SUCCESS_WHEN_FLAG step represents the normalized
action in a match. $MSTEP_FLAG is the flag
conditionning the success. $MSTEPSUCCESS_VAROCC is the tuple of
pattern variable occurrences, $MSTEPSUCCESS_BINDS is the list of local
binders, and $MSTEPSUCCESS_BODY is the normalized body tuple.}#
  :fields (
	   mstepsuccess_varocc
	   mstepsuccess_binds
	   mstepsuccess_body))

(defclass class_match_step_test
  :super class_match_step_with_data
  :doc #{The $CLASS_MATCH_STEP_TEST is the super-class of elementary
tests of pattern matching. The inherited $MSTEP_THEN is the then
branch, the $MSTEP_ELSE is the else branch. The inherited $MSTEP_DATA
is the tested data, and the inherited $MSTEP_INDEX is its index.}#
  :fields (mstep_else))

(defclass class_match_step_test_variable
  :super class_match_step_test
  :doc #{The $CLASS_MATCH_STEP_TEST_VARIABLE is for tests if the
data $MSTEPTESTVAR_DATA is the same as the matched data.}#
  :fields (msteptestvar_data))

(defclass class_match_step_test_constant
  :super class_match_step_test
  :doc #{The $CLASS_MATCH_STEP_TEST_CONSTANT is for tests if the
constant $MSTEPTESTCONST_DATA is the same as the matched data, using the $MSTEPTESTCONST_BIND bindinglist}#
  :fields (msteptestconst_data msteptestconst_bind))

(defclass class_match_step_test_group
  :super class_match_step_test
  :doc #{The $CLASS_MATCH_STEP_GROUP is used to redirect the then &
else tests to a list or tuple of subtests, i.e. to the $MSTGROUP_THEN and
$MSTGROUP_ELSE. The $MSTGROUP_START is the starting control point (for
then & else edges arriving into the group).}#
  :fields (mstgroup_start
	   mstgroup_then
	   mstgroup_else))


(defclass class_match_step_test_instance
  :super class_match_step_test
  :doc #{The $CLASS_MATCH_STEP_TEST_INSTANCE is the class for testing
instance membership. $MSTINS_CLASS is the tested class. $MSTINS_SLOTS
is the tuple of slot matched data.}#
  :fields (mstins_class
	   mstins_slots))

(defclass class_match_step_test_multiple
  :super class_match_step_test
  :doc #{The $CLASS_MATCH_STEP_TEST_MULTIPLE is the class for testing
  tupleness. $MSTTUP_COMPONENTS is the tuple of matched data
  components, or nil.}#
  :fields (msttup_components
	  ))

(defclass class_match_step_test_matcher
  :super class_match_step_test
  :doc #{The $CLASS_MATCH_STEP_TEST_MATCHER is the class for testing with
matcher. $MSTMA_MATCHER is the matcher, $MSTMA_BINDS is the local
binding list for inputs, $MSTMA_INS is the normalized inputs,
$MSTMA_OUTS is the tuple of output matched data.}#
  :fields (mstma_matcher
	   mstma_binds
	   mstma_ins
	   mstma_outs))


(defclass class_nrep_match_flag
  :super class_nrep_simple
  :doc #{The $CLASS_NREP_MATCH_FLAG is the normalized representation
of match flags, instances of $CLASS_MATCH_FLAG. $NRPFLA_FLAG is the
matched flag, and $NRPFLA_NMATCH is the instance of
$CLASS_NREP_MATCHALT using that match flag.}#
  :fields (nrpfla_flag
	   nrpfla_nmatch
	   ))

(defclass class_nrep_matched_data
  :super class_nrep_simple
  :doc #{The $CLASS_NREP_MATCHED_DATA is the normalized representation
of match data, instance of $CLASS_MATCHED_DATA. Field $NRPMATD_CTYPE
gives the ctype of the data. Field $NRMATD_MDATA gives the
originating matched data. Field $NRMATD_RANK is a unique rank.}#
  :fields (nrmatd_ctype
	   nrmatd_mdata
	   nrmatd_rank))
  

;;;;;;;;;;;;;;;;
;;; make a flag for a given source pattern in a given matching context
(defun make_match_flag (spat mcx str)
  (debug "make_match_flag spat=" spat " mcx=" mcx " str=" str)
  (assert_msg "check spat" (is_a spat class_source_pattern))
  (assert_msg "check mcx" (is_a mcx class_matching_context))
  (assert_msg "check str" (is_string str))
  (let ( (sloc (unsafe_get_field :loca_location spat))
	 (flaglist (unsafe_get_field :mctx_flags mcx))
	 (lastflag (pair_head (list_last flaglist)))
	 (:long lastrank (get_int (get_field :mflag_rank lastflag)))
	 )
    (assert_msg "check flaglist" (is_list flaglist))
    (assert_msg "check lastrank" (or (null lastflag) (>i lastrank 0)))
    (let ( (mflag
	    (instance class_match_flag
		      :loca_location sloc
		      :mflag_spat spat
		      :mflag_rank (make_integerbox discr_constant_integer
						   (+i lastrank 1))
		      :mflag_string str
			    ))
	   )
      (list_append flaglist mflag)
      (debug "make_match_flag return mflag" mflag)
      mflag
    )
))


;;;;;;;;;;;;;;;;
(defselector scan_subpatterns class_selector
  :doc #{Apply a given function $FUN to the subpatterns of receiver
  $RECV with extra context $CTX.}#
  :formals (recv fun ctx)
)

(defselector scan_step_data class_selector
  :doc #{Given a receiver $STEP, apply a given function $FUN to all
the data of the $STEP with an extra context $CTX.}#
  :formals (step fun ctx))

(defselector scan_step_flag class_selector
  :doc #{Given a receiver $STEP, apply a given function $FUN to all
the flags of the $STEP with an extra context $CTX.}#
  :formals (step fun ctx))

(defun scansubpat_anyrecv (recv fun ctx)
  (let ( (dis (discrim recv)) )
    (debug "scansubpat_anyrecv recv=" recv " of discrim=" dis)
    (errormsg_strv "unexpected scan_subpatterns for" (unsafe_get_field :named_name dis))
    (assert_msg "@$@unexpected scansubpat_anyrecv")
))
(install_method discr_any_receiver scan_subpatterns scansubpat_anyrecv)

(defun scanstepdata_anyrecv (recv fun ctx)
  (let ( (dis (discrim recv)) )
    (debug "scanstepdata_anyrecv recv=" recv " of discrim=" dis)
    (errormsg_strv "unexpected scan_step_data for" (unsafe_get_field :named_name dis))
    (assert_msg "@$@unexpected scanstepdata_anyrecv")
))
(install_method discr_any_receiver scan_step_data scanstepdata_anyrecv)

(defun scanstepflag_anyrecv (recv fun ctx)
  (let ( (dis (discrim recv)) )
    (debug "scanstepflag_anyrecv recv=" recv " of discrim=" dis)
    (errormsg_strv "unexpected scan_step_flag for" (unsafe_get_field :named_name dis))
    (assert_msg "@$@unexpected scanstepflag_anyrecv")
))
(install_method discr_any_receiver scan_step_flag scanstepflag_anyrecv)

(defun scansubpat_noop (recv fun ctx)
  (debug "scansubpat_noop recv=" recv)
  ()
)
(install_method class_source_pattern_variable scan_subpatterns scansubpat_noop)
(install_method class_source_pattern_constant scan_subpatterns scansubpat_noop)

(defun scansubpat_or (recv fun ctx)
  (debug "scansubpat_or recv=" recv)
  (let ( (disjtup (unsafe_get_field :orpat_disj recv)) )
    (foreach_in_multiple
     (disjtup)
     (curdisj :long dix)
     (fun curdisj ctx))))
(install_method class_source_pattern_or scan_subpatterns scansubpat_or)

(defun scansubpat_and (recv fun ctx)
  (debug "scansubpat_and recv=" recv)
  (let ( (conjtup (unsafe_get_field :andpat_conj recv)) )
    (foreach_in_multiple
     (conjtup)
     (curconj :long cix)
     (debug "scansubpat_and curconj=" curconj " cix=" cix)
     (fun curconj ctx))))
(install_method class_source_pattern_and scan_subpatterns scansubpat_and)


(defun scansubpat_construct (recv fun ctx)
  (debug "scansubpat_construct recv=" recv " fun=" fun)
  (shortbacktrace_dbg "scansubpat_construct" 10)
  (assert_msg "check recv" (is_a recv class_source_pattern_construct))
  (let ( (subpatup (get_field :ctpat_subpa recv)) )
    (debug "scansubpat_construct subpatup=" subpatup)
    (foreach_in_multiple
     (subpatup)
     (curpa :long pix)
     (debug "scansubpat_construct before curpa=" curpa " pix=" pix)
     (fun curpa ctx)
     (debug "scansubpat_construct after curpa=" curpa " pix=" pix)
     )))
(install_method class_source_pattern_construct scan_subpatterns scansubpat_construct)

(defun scansubpat_object (recv fun ctx)
  (debug "scansubpat_object recv=" recv)
  (let ( (patfieltup (unsafe_get_field :spat_fields recv)) )
    (foreach_in_multiple
     (patfieltup)
     (curpatfld :long flix)
     (if (is_a curpatfld class_source_field_pattern)
	 (fun (unsafe_get_field :spaf_pattern curpatfld) ctx)))))
(install_method class_source_pattern_object scan_subpatterns scansubpat_object)


(defun fill_matchcase (curmcase sloc)
  (debug "fill_matchcase curmcase=" curmcase " sloc=" sloc)
  (shortbacktrace_dbg "fill_matchcase" 10)
  (assert_msg "check curmcase" (is_a curmcase class_match_case))
  (let (
	(ourpatvarmap (make_mapobject discr_map_objects 17))
	(curscas (unsafe_get_field :mcase_source curmcase))
	(curpat (unsafe_get_field :scam_patt curscas))
	)
    (debug "fill_matchcase ourpatvarmap=" ourpatvarmap)
    (letrec (
	     (varpatscanner 
	      (lambda (pat patvarmap)
		(debug "fill_matchcase/varpatscanner pat=" pat " patvarmap=" patvarmap)
		(assert_msg "check patvarmap" (is_mapobject patvarmap))
		(assert_msg "same patvarmap" (== patvarmap ourpatvarmap))
		(shortbacktrace_dbg "fill_matchcase/varpatscanner" 10)
		(if (is_a pat class_source_pattern_variable)
		    (let (
			  (pvarsymb (unsafe_get_field :spatvar_symb pat))
			  (varocclist (mapobject_get patvarmap pvarsymb))
			  )
		      (if (null varocclist)
			  (progn 
			    (setq varocclist (make_list discr_list))
			    (mapobject_put patvarmap pvarsymb varocclist)
			    (debug "fill_matchcase/varpatscanner updated patvarmap=" patvarmap " for pat=" pat)
			    ))
		      (list_append varocclist pat)
		      )
		  (progn
		    (debug "fill_matchcase/varpatscanner before scan_subpatterns pat=" pat
			   "\n ourpatvarmap=" ourpatvarmap)
		    (scan_subpatterns pat varpatscanner ourpatvarmap)
		    (debug "fill_matchcase/varpatscanner after scan_subpatterns pat=" pat
			   "\n ourpatvarmap=" ourpatvarmap)
		    )
		  )
		))
	     )
      (debug "fill_matchcase before varpatscanner curpat=" curpat " ourpatvarmap=" ourpatvarmap "\n varpatscanner=" varpatscanner)
      (varpatscanner curpat ourpatvarmap)
      (debug "fill_matchcase after varpatscanner  curpat=" curpat "\n ourpatvarmap=" ourpatvarmap)
      )
    (debug "fill_matchcase final ourpatvarmap=" ourpatvarmap " for curmcase=" curmcase)
    (put_fields curmcase :mcase_varmap ourpatvarmap)
    ))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; the selectors to set the then & else part of a match step
(defselector put_then_match class_selector
  :doc #{Put the then part of a match test $RECV to $THENSTEP.}#
  :formals (recv thenstep)
)

(defun putthen_matchany (recv thenstep)
  (let ( (dis (discrim recv))
	 )
  (debug "putelse_mathany recv=" recv "thenstep=" thenstep " for discrim=" dis)
  (errormsg_strv "unexpected PUT_THEN_MATCH for " (get_field :named_name dis))
  (assert_msg "@$@unexpected PUT_THEN_MATCH [putthen_matchany]")
))
(install_method class_root put_then_match putthen_matchany)

(defun start_step (step)
  (cond 
   ( (null step)
     (return)
     )
   ( (is_a step class_match_step_test_group)
     (let ( (stastep (unsafe_get_field :mstgroup_start step))
	    )
       (debug "start_step group step" step)
       (debug "stastep return stastep" stastep)
       (assert_msg "check stastep" (is_a stastep class_match_step))
       (return stastep)))
   (:else
    (debug "start_step ordinary step" step)
    (assert_msg "check step" (is_a step class_match_step))
    (return step))))



(defun putthen_matchthen (recv thenstep)
  (debug "putthen_matchthen recv" recv)
  (assert_msg "check recv" (is_a recv class_match_step_then))
  (debug "putthen_matchthen thenstep" thenstep)
  (assert_msg "check thenstep" (is_a thenstep class_match_step))
  (assert_msg "check recv!=then" (!= recv thenstep))
  (compile_warning "temporary check for application depth..."
		   (assert_msg "putthen_matchthen check shallow100" 
			       (melt_application_shallower 100)))
  (compile_warning "temporary backtrace when test_instance...."
		   (if (is_a recv class_match_step_test_instance)
		       (shortbacktrace_dbg "putthen_matchthen testinstance!!!" 20)))
  (let ( (mythen (unsafe_get_field :mstep_then recv))
	 (starthen  (start_step thenstep))
	 )
    (if (== recv starthen)
	(progn
	  (debug "putthen_matchthen recv same starthen" starthen)
	  (return)))
    (if (== mythen starthen)
	(progn
	  (debug "putthen_matchthen mythen same starthen" starthen)
	  (return)))
    (if (null mythen)
	(progn
	  (unsafe_put_fields recv :mstep_then starthen)
	  (debug "putthen_matchthen updated recv" recv)
	  ;(shortbacktrace_dbg "putthen_matchthen" 12)
	  )
      (progn
	(debug "putthen_matchthen recursing in mythen" mythen)
	(debug "putthen_matchthen recursing for starthen" starthen)
	(put_then_match mythen starthen)
	(debug "putthen_matchthen did mythen" mythen))))
  )
(install_method class_match_step_then put_then_match putthen_matchthen)



(defun putthen_matchgroup (recv thenstep)
  (debug "putthen_matchgroup recv" recv)
  (assert_msg "check recv" (is_a recv class_match_step_test_group))
  (debug "putthen_matchgroup thenstep" thenstep)
  (assert_msg "check thenstep" (is_a thenstep class_match_step))
  (putthen_matchthen recv thenstep)
  (let ( (thengroup (unsafe_get_field :mstgroup_then recv)) )
    (cond 
     ((null thengroup)
      (return))
     ((is_a thengroup class_match_step)
      (put_then_match thengroup thenstep))
     ((is_list thengroup)
      (foreach_pair_component_in_list
       (thengroup)
       (curpair curthen)
       (put_then_match curthen thenstep)))
     ((is_multiple thengroup)
      (foreach_in_multiple
       (thengroup)
       (curthen :long thix)
       (put_then_match curthen thenstep)))
     (:else
      (debug "putthen_matchgroup bad thengroup" thengroup)
      (assert_msg "bad thengroup" ())))))
(install_method class_match_step_test_group put_then_match putthen_matchgroup)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defselector put_else_match class_selector
  :doc #{Put the else part of a match test $RECV to $ELSESTEP.}#
  :formals (recv elsestep)
)

(defun putelse_matchany (recv elsestep)
  (let ( (dis (discrim recv))
	 )
  (debug "putelse_mathany recv=" recv "elsestep=" elsestep " for discrim=" dis)
  (errormsg_strv "unexpected PUT_ELSE_MATCH for " (get_field :named_name dis))
  (assert_msg "@$@unexpected PUT_ELSE_MATCH [putelse_matchany]")
))
(install_method class_root put_else_match putelse_matchany)

;; method to putelse inside then-steps
(defun putelse_matchstepthen (recv elsestep)
  (debug "putelse_matchstepthen recv=" recv "\n elsestep=" elsestep)
  (shortbacktrace_dbg "putelse_matchstepthen" 10)
  (assert_msg "check recv" (is_a recv class_match_step_then))
  (debug "putelse_matchstepthen elsestep" elsestep)
  (assert_msg "check elsestep" (is_a elsestep class_match_step))
  (compile_warning "temporary check for application depth..."
		   (assert_msg "putelse_matchstepthen check shallow100" 
			       (melt_application_shallower 100)))
  (let ( 
	(mythen (unsafe_get_field :mstep_then recv))
	(elsestart (start_step elsestep))
	)
    (cond 
     ( (== recv elsestart)
       (debug "putelse_matchstepthen recv same elsestart" recv)
       (return))
     ( (== mythen elsestep)
       (debug "putelse_matchstepthen mythen same elsestep" mythen)
       (return))
     ( (== mythen elsestart)
       (debug "putelse_matchstepthen mythen same elsestart" mythen)
       (return))
     (mythen 
      (debug "putelse_matchstepthen recursing in mythen" mythen)
      (debug "putelse_matchstepthen recursing for elsestart" elsestart)
      (debug "putelse_matchstepthen recursing from recv" recv)
      (put_else_match mythen elsestart)
      (debug "putelse_matchstepthen done recursing in mythen" mythen))
     )
  (debug "putelse_matchstepthen end recv" recv)))

(install_method class_match_step_then put_else_match putelse_matchstepthen)

	  
;; method to putelse inside tests
(defun putelse_matchtest (recv elsestep)
  (debug "putelse_matchtest recv=" recv " elsestep=" elsestep)
  (shortbacktrace_dbg "putelse_matchtest" 10)
  (assert_msg "check recv" (is_a recv class_match_step_test))
  (assert_msg "check elsestep" (is_a elsestep class_match_step))
  (compile_warning "temporary check for application depth..."
		   (assert_msg "putelse_matchtest check shallow100" 
			       (melt_application_shallower 100)))
  (let ( 
	(myelse (unsafe_get_field :mstep_else recv))
	(mythen (unsafe_get_field :mstep_then recv))
	(elsestart (start_step elsestep))
	)
    (cond 
     ( (== recv elsestep)
       (debug "putelse_matchtest recv same as elsestep=" recv)
       (return))
     ( (== recv elsestart)
       (debug "putelse_matchtest recv same as elsestart=" recv)
       (return))
     ( (== myelse elsestart)
       (debug "putelse_matchtest myelse same as elsestart=" recv)
       (return))
     ( (== myelse elsestep)
       (debug "putelse_matchtest myelse same as elsestep=" recv)
       (return))
     ( (== mythen elsestep)
       (debug "putelse_matchtest mythen same as elsestep=" recv)
       (return))
     ( (== mythen elsestart)
       (debug "putelse_matchtest mythen same as elsestart=" recv)
       (return))
     ( (null myelse)
       (put_fields recv :mstep_else elsestart)
       (debug "putelse_matchtest updated recv=" recv)
       (shortbacktrace_dbg "putelse_matchtest" 12)
       )
     (:else
      (debug "putelse_matchtest myelse appending then" myelse)
      (put_then_match myelse elsestart)
      )
     )
    (if mythen
	(progn
	  (debug "putelse_matchtest recursing in mythen=" mythen 
		 "\n..with elsestart=" elsestart)
	  (put_else_match mythen elsestart)))
    ;;
    (debug "putelse_matchtest end recv=" recv)
    ))
(install_method class_match_step_test put_else_match putelse_matchtest)


;;;;;;;;;;;;;;;;
(defun putelse_matchgroup (recv elsestep)
  (debug "putelse_matchgroup recv=" recv "\n elsestep=" elsestep)
  (assert_msg "check recv" (is_a recv class_match_step_test_group))
  (assert_msg "check elsestep" (is_a elsestep class_match_step))
  (shortbacktrace_dbg "putelse_matchgroup" 10)
  (let ( (elsegroup (unsafe_get_field :mstgroup_else recv)) 
	 (elsestart (start_step elsestep))
	 (startgroup (unsafe_get_field :mstgroup_start recv))
	 )
    (debug "putelse_matchgroup elsestart=" elsestart "\n startgroup=" startgroup)
    (when startgroup
      (debug "putelse_matchgroup recursing startgroup=" startgroup)
      (put_else_match startgroup elsestart)
	  )
    (debug "putelse_matchgroup elsegroup=" elsegroup)
    (cond 
     ((null elsegroup)
      ())
     ((is_a elsegroup class_match_step)
      (debug "putelse_matchgroup elsegroup=" elsegroup)
      (put_else_match elsegroup elsestart))
     ((is_list elsegroup)
      (foreach_pair_component_in_list
       (elsegroup)
       (curpair curelse)
       (debug "putelse_matchgroup  from list curelse=" curelse)
       (put_else_match curelse elsestart)))
     ((is_multiple elsegroup)
      (foreach_in_multiple
       (elsegroup)
       (curelse :long thix)
       (debug "putelse_matchgroup  from tuple curelse=" curelse)
       (put_else_match curelse elsestart)))
     (:else
      (debug "putelse_matchgroup bad elsegroup=" elsegroup)
      (assert_msg "bad elsegroup" ())))
    (debug "putelse_matchgroup end recv=" recv)
    ))
(install_method class_match_step_test_group put_else_match putelse_matchgroup)


;;;;;;;;;;;;;;;;
(defun scanstepdata_testins (step fun ctx)
  (assert_msg "check step" (is_a step class_match_step_test_instance))
  (debug "scanstepdata_testins step=" step " fun=" fun)
  (let ( (slotup (unsafe_get_field :mstins_slots step)) 
	 )
    (foreach_in_multiple 
     (slotup)
     (curslot :long ix)
     (if curslot 
	 (fun curslot ctx)))))
(install_method class_match_step_test_instance scan_step_data scanstepdata_testins)

(defun scanstepdata_testtuple (step fun ctx)
  (debug "scanstepdata_testtuple step=" step " fun=" fun)
  (assert_msg "check step" (is_a step class_match_step_test_multiple))
  (let ( (mtupcomp (get_field :msttup_components step))
	 )
    (debug "scanstepdata_testtuple mtupcomp=" mtupcomp)
    (foreach_in_multiple
     (mtupcomp)
     (curcomp :long mix)
     (if curcomp
	 (fun curcomp ctx))
     )
))
(install_method  class_match_step_test_multiple  scan_step_data  scanstepdata_testtuple)


;;; scan step data for test with flag is a no-op
(defun scanstepdata_testwithflag (step fun ctx)
  (debug "scanstepdata_testwithflag step=" step " fun=" fun)
  )
(install_method class_match_step_with_flag scan_step_data scanstepdata_testwithflag)


(defun scanstepdata_testmatcher (step fun ctx)
  (assert_msg "check step" (is_a step class_match_step_test_matcher))
  (let ( (outs (unsafe_get_field :mstma_outs step)) 
	 )
    (foreach_in_multiple
     (outs)
     (curout :long outix)
     (if curout (fun curout ctx)))
    ))
(install_method class_match_step_test_matcher scan_step_data scanstepdata_testmatcher)

;;;

(defun scanstepdata_testvariable (step fun ctx)
  (debug "scanstepdata_testvariable step=" step "\n fun=" fun "\n ctx=" ctx)
  (assert_msg "check step" (is_a step class_match_step_test_variable))
  (let ( (tvdata (get_field :msteptestvar_data step))
	 )
    (if tvdata (fun tvdata ctx)))
)
(install_method class_match_step_test_variable scan_step_data scanstepdata_testvariable)

;;;

(defun scanstepflag_stepwithflag (step fun ctx)
  (assert_msg "check step" (is_a step class_match_step_with_flag))
  (let ( (flag (unsafe_get_field :mstep_flag step)) 
	 )
    (if flag (fun flag ctx))
    ))
(install_method class_match_step_with_flag scan_step_flag 
		scanstepflag_stepwithflag)

(defun scanstepflag_stepflagoper (step fun ctx)
  (assert_msg "check step" (is_a step class_match_step_flag_operation))
  (let ( (flag (unsafe_get_field :mstep_flag step))
	 (flagargs (unsafe_get_field :mstep_flagargs step))
	 )
    (if flag (fun flag ctx))
    (if flagargs
	(foreach_in_multiple 
	 (flagargs) 
	 (curflag :long flagix) 
	 (fun curflag ctx)))
    ))

(install_method class_match_step_flag_operation scan_step_flag
		scanstepflag_stepflagoper)


;; scan step flag on step with data is a no-op
(defun scanstepflag_stepwithdata (step fun ctx)
  (debug "scanstepflag_stepwithdata step=" step " fun=" fun)
  (assert_msg "check step" (is_a step class_match_step_with_data))
)
(install_method class_match_step_with_data scan_step_flag
		scanstepflag_stepwithdata)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; the selector to translate a pattern
(defselector translate_pattern class_selector
  :doc #{Translate a pattern into a match step. $RECV is the receiver,
  $MDATA is the matched data, $MCASE is the match case, and $SLOC is
  the source location. Returns the match step and secundarily the match flag.}#
  :formals (recv mdata mcase varmap sloc))


(defun translpat_anyrecv (recv mdata mcase varmap sloc)
  (debug "translpat_anyrecv recv" recv)
  (debug "translpat_anyrecv mdata" mdata)
  (let ( (dis (discrim recv)) )
    (debug "translpat_anyrecv dis" dis)
    (error_strv sloc "unexpected TRANSLATE_PATTERN for" (unsafe_get_field :named_name dis))
    (assert_msg "@$@unexpected translpat_anyrecv")
))
(install_method discr_any_receiver translate_pattern translpat_anyrecv)

(defun translpat_jokerpat (recv mdata mcase varmap sloc)
  (assert_msg "check recv" (is_a recv class_source_pattern_joker_variable))
  (debug "translpat_jokerpat recv" recv)
  (return)
)
(install_method class_source_pattern_joker_variable translate_pattern translpat_jokerpat)


(defun translpat_constpat (recv mdata mcase varmap psloc)
  (debug "translpat_constpat recv" recv)
  (assert_msg "check recv" (is_a recv class_source_pattern_constant))
  (debug "translpat_constpat mdata" mdata)
  (assert_msg "check mdata" (is_a mdata class_matched_data))
  (debug "translpat_constpat mcase" mcase)
  (assert_msg "check mcase" (is_a mcase class_match_case))
  (let ( 
	(sloc (or (unsafe_get_field :loca_location recv) psloc))
	(spatweight (unsafe_get_field :pat_weight recv))
	(sconstx (unsafe_get_field :spat_constx recv))
	(mctxt (unsafe_get_field :mcase_mctxt mcase))
	(ncx (get_field :mctx_normctxt mctxt))
	(env (get_field :mctx_env mctxt))
	(steplist (get_field :mdata_steps mdata))
	)
    (assert_msg "check ncx" (is_a ncx class_normalization_context))
    (assert_msg "check env" (is_a env class_environment))
    (assert_msg "check steplist" (is_list steplist))
    (debug "translpat_constpat before normalization sconstx" sconstx)
    (multicall
     (nconst nbindconst)
     (normal_exp sconstx env ncx sloc)
     (debug "translpat_constpat nconst" nconst)
     (debug "translpat_constpat nbindconst" nbindconst)
     (let (
	   (mflag (make_match_flag recv mctxt
				   (or (get_field :named_name nconst) '"constant_pattern")))
	   (flagstep (instance class_match_step_flag_set
				     :loca_location sloc
				     :mstep_then ()
				     :mstep_flag mflag))
	   (steptest (instance class_match_step_test_constant
			       :loca_location sloc
			       :mstep_data mdata
			       :mstep_then flagstep
			       :mstep_else ()
			       :msteptestconst_data nconst
			       :msteptestconst_bind nbindconst
			       ))
	   )
       (debug "translpat_constpat flagstep=" flagstep "\n steptest=" steptest)
       (shortbacktrace_dbg "translpat_constpat" 7)
       (list_append steplist steptest)
       (list_append steplist flagstep)
       (debug "translpat_constpat return steptest=" steptest 
	      "\n.. mflag=" mflag)
       (return steptest mflag)
       ;;
       ))))
(install_method class_source_pattern_constant translate_pattern translpat_constpat)



;;;;;;;;;;;;;;;;
(defun translpat_listpat (recv mdata mcase varmap sloc)
  (assert_msg "check recv" (is_a recv class_source_pattern_list))
  (debug "translpat_listpat recv" recv)
  (error_plain sloc "@@unimplemented translpat_listpat")
  (assert_msg "$@$ translpat_listpat unimplemented")
)
(install_method class_source_pattern_list translate_pattern translpat_listpat)



;;;;;;;;;;;;;;;;
(defun translpat_tuplepat (recv mdata mcase varmap psloc)
  (debug "translpat_tuplepat recv=" recv " mdata=" mdata " mcase=" mcase)
  (assert_msg "check recv" (is_a recv class_source_pattern_tuple))
  (assert_msg "check mdata" (is_a mdata class_matched_data))
  (assert_msg "check mcase" (is_a mcase class_match_case))
  (let ( (sloc (or (unsafe_get_field :loca_location recv) psloc))
	 (subpatup (unsafe_get_field :ctpat_subpa recv))
	 (:long nbsubpat (multiple_length subpatup))
	 (patcomplist (make_list discr_list))
	 (mctxt (unsafe_get_field :mcase_mctxt mcase))
	 )
    (foreach_in_multiple
     (subpatup)
     (cursubpat :long patix)
     (debug "translpat_tuplepat cursubpat=" cursubpat 
	    " patix=" patix)
     (assert_msg "check cursubpat" (is_a cursubpat class_source_pattern))
     (if (is_not_a cursubpat class_source_pattern_joker_variable)
	 (let ( (tucomp (instance class_tuple_component_pattern
				  :tupcp_pattern cursubpat
				  :tupcp_index (make_integerbox discr_constant_integer patix)))
		)
	   (list_append patcomplist tucomp)
	   )))
    (debug "translpat_tuplepat  patcomplist=" patcomplist)
    (let ( (rawpatcomptup (list_to_multiple patcomplist discr_multiple))
	   (sortedpatcomptup
	    (multiple_sort
	     rawpatcomptup
	     (lambda (tc1 tc2)
	       (let ( (:long wtc1 (get_int (get_field :pat_weight (get_field :tupcp_pattern tc1))))
		      (:long wtc2 (get_int (get_field :pat_weight (get_field :tupcp_pattern tc2))))
		      )
		 (cond
		  ( (==i wtc1 wtc2) '0)
		  ( (<i wtc1 wtc2) '1)
		  (:else '-1))))
	     discr_multiple))
	   )
      (debug "translpat_tuplepat sortedpatcomptup=" sortedpatcomptup 
	     "\n class_match_step_test_multiple=" class_match_step_test_multiple)
      ;; find our step if its exist or else create it, also find the
      ;; last test step to add our new test in its else case
      (let ( (istep ())
	     (laststeptest ())
	     (steplist (get_field :mdata_steps mdata))
	     )
	(assert_msg "check steplist" (is_list steplist))
	(foreach_pair_component_in_list
	 (steplist)
	 (curpair curstep)
	 (cond 
	  ( (and (is_a curstep class_match_step_test_multiple)
		 (==i (multiple_length (get_field :msttup_components curstep))
		      nbsubpat))
	    (setq curpair ())
	    (setq istep curstep))
	  ( (is_a curstep class_match_step_test)
	    (setq laststeptest curstep))
	  ))				; end foreach in steplist
	(debug "translpat_tuplepat laststeptest=" laststeptest " istep=" istep)
	;; create the istep if not found
	(if (null istep)
	    (let (
		  (dcomp (make_multiple discr_multiple nbsubpat))
		  (newstep (instance class_match_step_test_multiple
				     :loca_location sloc
				     :mstep_data mdata
				     :mstep_then ()
				     :mstep_else ()
				     :msttup_components dcomp))
		  )
	      (setq istep newstep)
	      (debug "translpat_tuplepat newstep" newstep)
	      (list_append steplist newstep)
	      (debug "translpat_tuplepat updated steplist=" steplist)
	      (if laststeptest
		  (progn 
		    (put_else_match laststeptest newstep)
		    (debug "translpat_tuplepat updated laststeptest=" laststeptest)))
	      ))
	;; translate each subpattern
	(let (
	      (laststep istep)
	      (dcomp (get_field :msttup_components istep))
	      (flaglist (make_list discr_list))
	      (elselist (make_list discr_list))
	      )
	  (debug "translpat_tuplepat dcomp=" dcomp)
	  (list_append elselist istep)
	  (foreach_in_multiple
	   (sortedpatcomptup)
	   (curpatcomp :long curpix)
	   (debug "translpat_tuplepat curpatcomp=" curpatcomp " curpix=" curpix)
	   (assert_msg "check curpatcomp" (is_a curpatcomp class_tuple_component_pattern))
	   (let ( (curpat (get_field :tupcp_pattern curpatcomp))
		  (:long pix (get_int (get_field :tupcp_index curpatcomp)))
		  (curdata (multiple_nth dcomp pix))
		  )
	     (debug "translpat_tuplepat curpat=" curpat " pix=" pix " curdata=" curdata)
	     (assert_msg "check curpat" (is_a curpat class_source_pattern))
	     (if (null curdata)
		 (let ( (newdata (instance class_matched_data
					   :mdata_symb (clone_symbol 'patuplecomp)
					   :mdata_ctype ctype_value
					   :mdata_orig istep
					   :mdata_steps (make_list discr_list)))
			)
		   (debug "translpat_tuplepat newdata=" newdata " for istep=" istep " pix=" pix)
		   (setq curdata newdata)
		   (multiple_put_nth dcomp pix newdata)
		   ))
	     (debug "translpat_tuplepat before translating curpat=" curpat " with istep=" istep)
	     (multicall
	      (substep subflag)
	      (translate_pattern curpat curdata mcase varmap psloc)
	      (debug "translpat_tuplepat after translating curpat=" curpat " substep=" substep
		     " subflag=" subflag)
	      (if substep
		  (progn 
		    (debug "translpat_tuplepat laststep=" laststep)
		    (put_then_match laststep substep)
		    (list_append elselist substep)
		    (setq laststep substep)))
	      (if subflag
		  (progn
		    (debug "translpat_tuplepat subflag=" subflag)
		    (list_append flaglist subflag)))
	      )
	     )
	   )
	  ;;
	  (debug "translpat_tuplepat elselist" elselist)
	  (let ( 
		(mflag (make_match_flag recv mctxt '"tuple"))
		(stepsetflag
		 (if (list_first_element flaglist)
		     (instance class_match_step_flag_conjunction
			       :loca_location sloc
			       :mstep_then ()
			       :mstep_flag mflag
			       :mstep_flagargs (list_to_multiple flaglist discr_multiple))
		   (instance class_match_step_flag_set
			     :loca_location sloc
			     :mstep_then ()
			     :mstep_flag mflag)))
		(stepgroup (instance class_match_step_test_group
				     :loca_location sloc
				     :mstep_data mdata
				     :mstep_then ()
				     :mstep_else ()
				     :mstgroup_start istep
				     :mstgroup_then stepsetflag
				     :mstgroup_else (list_to_multiple elselist discr_multiple)
				     ))
		)
	    (put_fields mflag :mflag_setstep stepsetflag)
	    (debug "translpat_tuplepat stepsetflag=" stepsetflag "\n mflag=" mflag)
	    (put_then_match laststep stepsetflag)
	    (debug "translpat_tuplepat return stepgroup=" stepgroup " mflag=")
	    (return stepgroup mflag)
	    ))))))
(install_method class_source_pattern_tuple translate_pattern translpat_tuplepat)





;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun translpat_inspat (recv mdata mcase varmap psloc)
  (debug "translpat_inspat recv" recv)
  (assert_msg "check recv" (is_a recv class_source_pattern_instance))
  (debug "translpat_inspat mdata" mdata)
  (assert_msg "check mdata" (is_a mdata class_matched_data))
  (debug "translpat_inspat mcase" mcase)
  (assert_msg "check mcase" (is_a mcase class_match_case))
  (let ( 
	(pclass (unsafe_get_field :spat_class recv))
	(pfields (unsafe_get_field :spat_fields recv))
	(sloc (or (unsafe_get_field :loca_location recv) psloc))
	(mctxt (unsafe_get_field :mcase_mctxt mcase))
	)
    (assert_msg "check pclass" (is_a pclass class_class))
    (let ( (:long nbfields (multiple_length (unsafe_get_field :class_fields pclass)))
	   (mflag (make_match_flag recv mctxt (get_field :named_name pclass)))
	   )
      ;; check that each mentioned field is indeed a field of the class
      (foreach_in_multiple
       (pfields)
       (curpfld :long pix)
       (assert_msg "check curpfld" (is_a curpfld class_source_field_pattern))
       (let ( (fsloc (or (unsafe_get_field :loca_location curpfld) sloc))
	      (curfld (unsafe_get_field :spaf_field curpfld))
	      (flcla (get_field :fld_ownclass curfld))
	      )
	 (assert_msg "check curfld" (is_a curfld class_field))
	 (cond ( (not (subclass_or_eq pclass flcla))
		 (error_strv sloc "bad field in object pattern"
			     (unsafe_get_field :named_name curfld))
		 (inform_strv sloc "class in pattern is" (get_field :named_name pclass))
		 (inform_strv sloc "class of field is" (get_field :named_name flcla))
		 (return)))
	 ))
      ;; find our step if its exist or else create it, also find the
      ;; last test step to add our new test in its else case
      (let ( (istep ())
	     (laststeptest ())
	     (steplist (get_field :mdata_steps mdata))
	     )
	(assert_msg "check steplist" (is_list steplist))
	(foreach_pair_component_in_list
	 (steplist)
	 (curpair curstep)
	 (cond 
	  ( (and (is_a curstep class_match_step_test_instance)
		 (== (unsafe_get_field :mstins_class curstep) pclass))
	    (setq curpair ())
	    (setq istep curstep)
	    )
	  ( (is_a curstep class_match_step_test)
	    (setq laststeptest curstep))
	  ))
	(debug "translpat_inspat laststeptest" laststeptest)
	;;
	(if (null istep)
	    (let 
		( 
		 (dslots (make_multiple discr_multiple nbfields))
		 (newstep (instance class_match_step_test_instance
				    :loca_location sloc
				    :mstep_data mdata
				    :mstep_then ()
				    :mstep_else ()
				    :mstins_class pclass
				    :mstins_slots dslots
				    ))
		 )
	      (setq istep newstep)
	      (debug "translpat_inspat newstep" newstep)
	      (list_append steplist newstep)
	      (debug "translpat_inspat updated steplist" steplist)
	      (if laststeptest
		  (progn 
		    (put_else_match laststeptest newstep)
		    (debug "translpat_inspat updated laststeptest" laststeptest)))
	      ))
	;; translate each mentioned non-joker field 
	(let ( (mslots (unsafe_get_field :mstins_slots istep))
	       (laststep istep)
	       (flaglist (make_list discr_list))
	       (elselist (make_list discr_list))
	       )
	  (assert_msg "check mslots" (is_multiple mslots))
	  (list_append elselist istep)
	  (foreach_in_multiple
	   (pfields)
	   (curpfld :long pix)
	   (assert_msg "check curpfld" (is_a curpfld class_source_field_pattern))
	   (let ( (fsloc (or (unsafe_get_field :loca_location curpfld) sloc))
		  (curfld (unsafe_get_field :spaf_field curpfld))
		  (curfpat (unsafe_get_field :spaf_pattern curpfld))
		  )
	     (if (is_not_a curfpat class_source_pattern_joker_variable)
		 (let ( (:long curfix (get_int curfld))
			(curslotdata (multiple_nth mslots curfix))
			)
		   (if (null curslotdata)
		       (let ( (newslot (instance class_matched_data
						 :mdata_symb (clone_symbol curfld)
						 :mdata_ctype ctype_value
						 :mdata_orig istep
						 :mdata_steps (make_list discr_list)
						 )) 
			      )
			 (debug " translpat_inspat newslot" newslot)
			 (setq curslotdata newslot)
			 (multiple_put_nth mslots curfix newslot)))
		   (debug "translpat_inspat before translation curfpat" curfpat)
		   (multicall
		    (flstep flflag)
		    (translate_pattern curfpat curslotdata mcase varmap psloc) 
		    (debug "translpat_inspat flstep" flstep)
		    (debug "translpat_inspat flflag" flflag)
		    (if flstep 
			(progn
			  (debug "translpat_inspat laststep" laststep)
			  (put_then_match laststep flstep)
			  (list_append elselist flstep)
			  (setq laststep flstep)
			  ))
		    (if flflag
			(list_append flaglist flflag))
		    )))))
	  (debug "translpat_inspat elselist" elselist)
	  (let ( 
		(stepsetflag
		 (if (list_first_element flaglist)
		     (instance class_match_step_flag_conjunction
			       :loca_location sloc
			       :mstep_then ()
			       :mstep_flag mflag
			       :mstep_flagargs (list_to_multiple flaglist discr_multiple))
		   (instance class_match_step_flag_set
			     :loca_location sloc
			     :mstep_then ()
			     :mstep_flag mflag)))
		(stepgroup (instance class_match_step_test_group
				     :loca_location sloc
				     :mstep_data mdata
				     :mstep_then ()
				     :mstep_else ()
				     :mstgroup_start istep
				     :mstgroup_then stepsetflag
				     :mstgroup_else (list_to_multiple elselist discr_multiple)
				     ))
		)
	    (put_fields mflag :mflag_setstep stepsetflag)
	    (debug "translpat_inspat stepsetflag=" stepsetflag "\n mflag=" mflag)
	    (shortbacktrace_dbg "translpat_inspat" 8)
	    (put_then_match laststep stepsetflag)
	    (debug "translpat_inspat return stepgroup" stepgroup)
	    (return stepgroup mflag)
	    ))))))
(install_method class_source_pattern_instance translate_pattern translpat_inspat)


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


(defun translpat_varpat (recv mdata mcase varmap psloc)
  (debug "translpat_varpat recv=" recv " mdata=" mdata " mcase=" mcase 
	 " varmap=" varmap)
  (assert_msg "check recv" (is_a recv class_source_pattern_variable))
  (assert_msg "check mdata" (is_a mdata class_matched_data))
  (assert_msg "check mcase" (is_a mcase class_match_case))
  (shortbacktrace_dbg "translpat_varpat" 15)
  (let ( 
	(sloc (or (unsafe_get_field :loca_location recv) psloc))
	(symb (unsafe_get_field :spatvar_symb recv))
	(matctx (unsafe_get_field  :mcase_mctxt mcase))
	(symbval (mapobject_get varmap symb))
	(mhandlers (get_field :mctx_varhandlers matctx))
	(steplist (get_field :mdata_steps mdata))
	(mctxt (unsafe_get_field :mcase_mctxt mcase))
	(mflag (make_match_flag recv mctxt (get_field :named_name symb)))
	(flagstep (instance class_match_step_flag_set 
			    :loca_location sloc
			    :mstep_then ()
			    :mstep_flag mflag))
	)
    (debug "translpat_varpat symb=" symb "\n symbval=" symbval "\n flagstep=" flagstep)
    (shortbacktrace_dbg "translpat_varpat" 15)
    (assert_msg "check steplist" (is_list steplist))
    (put_fields mflag :mflag_setstep flagstep)
    (debug "translpat_varpat flagstep" flagstep)
    (cond 
     ( (null symbval)
       (mapobject_put varmap symb mdata)
       (debug "translpat_varpat updated varmap & return null" varmap)
       (list_append steplist flagstep)
       (foreach_pair_component_in_list
	(mhandlers)
	(curpair curhandler)
	(debug "translpat_varpat before calling curhandler=" curhandler
	       " recv=" recv " mdata=" mdata)
	(curhandler recv mdata mcase symbval flagstep mflag sloc))
       (debug "translpat_varpat return mflag=" mflag " flagstep=" flagstep)
       (return flagstep mflag)
       )
     (:else
      (assert_msg "check symbval" (is_a symbval class_matched_data))
      (let ( (laststeptest ())
	     )
	(foreach_pair_component_in_list
	 (steplist)
	 (curpair curteststep)
	 (cond
	  ( (and (is_a curteststep class_match_step_test_variable)
		 (== (unsafe_get_field :msteptestvar_data curteststep) symbval))
	    (progn
	      (debug "translpat_varpat found curteststep" curteststep)
	      (put_then_match curteststep flagstep)
	      (foreach_pair_component_in_list
	       (mhandlers)
	       (curpair curhandler)
	       (curhandler recv mdata mcase symbval curteststep mflag sloc))
	      (debug "translpat_varpat return mflag" mflag)
	      (debug "translpat_varpat return curteststep" curteststep)
	      (return curteststep mflag)))
	  ( (is_a curteststep class_match_step_test)
	    (setq laststeptest curteststep))
	  )
	 )
	(debug "translpat_varpat laststeptest" laststeptest)
	(let ( (steptest (instance class_match_step_test_variable
				   :loca_location sloc
				   :mstep_data mdata
				   :mstep_then flagstep
				   :msteptestvar_data symbval
				   ))
	       )
	  (list_append steplist steptest)
	  (debug "translpat_varpat made steptest" steptest)
	  (if laststeptest
	      (progn
		(debug "translpat_varpat before put_else_match laststeptest=" laststeptest 
		       "\n.. steptest=" steptest)
		(put_else_match laststeptest steptest)
		(debug "translpat_varpat updated laststeptest" laststeptest)))
	  (foreach_pair_component_in_list
	   (mhandlers)
	   (curpair curhandler)
	   (curhandler recv mdata mcase symbval steptest mflag sloc))
	  (debug "translpat_varpat return mflag" mflag)
	  (debug "translpat_varpat return steptest" steptest)
	  (return steptest mflag)
	  ))))
    (assert_msg "@$@failed translpat_varpat")
    ))
(install_method class_source_pattern_variable translate_pattern translpat_varpat)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; translation of and-patterns
(defun translpat_andpat (recv mdata mcase varmap psloc)
  (debug "translpat_andpat recv=" recv "\n.. mdata=" mdata
	 "\n.. mcase=" mcase "\n.. varmap=" varmap)
  (assert_msg "check recv" (is_a recv class_source_pattern_and))
  (assert_msg "check mdata" (is_a mdata class_matched_data))
  (assert_msg "check mcase" (is_a mcase class_match_case))
  (shortbacktrace_dbg "translpat_andpat" 10)
  (let (
	(sloc (or (unsafe_get_field :loca_location recv) psloc))
	(sconj (unsafe_get_field :andpat_conj recv))
	(curstep ())
	(firststep ())
	(thenlist (make_list discr_list))
	(elselist (make_list discr_list))
	(flaglist (make_list discr_list))
	(mctxt (unsafe_get_field :mcase_mctxt mcase))
	(stepgroup (instance class_match_step_test_group
			     :loca_location sloc
			     :mstep_data mdata
			     :mstgroup_start ()
			     :mstgroup_then ()
			     :mstgroup_else ()
			     ))
	(mflag (make_match_flag recv mctxt '"and"))
	(flagstep (instance class_match_step_flag_conjunction
			    :loca_location sloc
			    :mstep_then ()
			    :mstep_flag mflag
			    ))
	)
    (assert_msg "check sconj" (is_multiple sconj))
    (debug "translpat_andpat flagstep=" flagstep " sconj=" sconj)
    (put_fields mflag :mflag_setstep flagstep)
    ;;
    (foreach_in_multiple
     (sconj)
     (curconj :long conjix)
     (debug "translpat_andpat curconj=" curconj "\n..firststep=" firststep 
	    "\n..curstep=" curstep "\n.. conjix=" conjix)
     (multicall 
      (conjstep conjflag)
      (translate_pattern curconj mdata mcase varmap sloc)
      (debug "translpat_andpat curconj=" curconj "\n.. conjstep=" conjstep "\n.. conjflag=" conjflag)
      (when conjstep
	(if (null curstep)
	    (progn
	      (setq firststep conjstep)
	      (debug "translpat_andpat firststep" firststep)
	      (list_append thenlist firststep)
	      )
	  (progn
	    (debug "translpat_andpat curstep" curstep)
	    (put_then_match curstep conjstep)
	    )
	  )
	(list_append elselist conjstep)
	(setq curstep conjstep)
	)
      ;;
      (when conjflag
	(assert_msg "check conjflag" (is_a conjflag class_match_flag))
	(list_append flaglist conjflag))
      ))				;end foreach_in_multiple sconj
    ;;
    (put_fields stepgroup
		:mstgroup_start firststep
		:mstgroup_then (list_to_multiple thenlist discr_multiple)
		:mstgroup_else (list_to_multiple elselist discr_multiple))
    (cond ( (null firststep)
	    ;; this happens only for degenerate conjunctions like ?(and ?_)
	    (warning_plain sloc "degenerate ?(AND ...) pattern")
	    (return)
	    )
	  )
    (put_fields flagstep :mstep_flagargs (list_to_multiple flaglist discr_multiple))
    (put_then_match stepgroup flagstep)
    (debug "translpat_andpat return stepgroup=" stepgroup "\n mflag=" mflag)
    (return stepgroup mflag)
    ))
(install_method class_source_pattern_and translate_pattern translpat_andpat)




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; translation of or-patterns
(defun translpat_orpat (recv  mdata mcase varmap psloc)
  (debug "translpat_orpat recv=" recv "\n.. mdata=" mdata "\n.. mcase=" mcase "\n.. varmap=" varmap)
  (assert_msg "check recv" (is_a recv class_source_pattern_or))
  (debug "translpat_orpat mdata" mdata)
  (assert_msg "check mdata" (is_a mdata class_matched_data))
  (debug "translpat_orpat mcase" mcase)
  (assert_msg "check mcase" (is_a mcase class_match_case))
  (let (
	(firststep ())
	(prevstep ())
	(sloc (or (unsafe_get_field :loca_location recv) psloc))
	(sdisj (unsafe_get_field :orpat_disj recv))
	(mctxt (unsafe_get_field :mcase_mctxt mcase))
	(mhandlers (get_field :mctx_varhandlers mctxt))
	(stepgroup (instance class_match_step_test_group
			     :loca_location sloc
			     :mstep_data mdata
			     :mstgroup_start ()
			     :mstgroup_then ()
			     :mstgroup_else ()
			     ))
	(mflag (make_match_flag recv mctxt '"or"))
	(flagstep (instance class_match_step_flag_disjunction
			    :loca_location sloc
			    :mstep_then ()
			    :mstep_flag mflag
			    ))
	(flaglist (make_list discr_list))
	(steplist (make_list discr_list))
	)
    (debug "translpat_orpat flagstep" flagstep)
    (assert_msg "check sdisj" (is_multiple sdisj))
    (foreach_in_multiple
     (sdisj)
     (curdisj :long disjix)
     (debug "translpat_orpat curdisj" curdisj)
     (let (
	   (newvarmap (make_mapobject discr_map_objects 11))
	   (varhandler
	    (lambda 
	      (varpat varmdata varmcase varsymbval varflagstep varmflag varsloc)
	      (debug "translpat_orpat.varhandler varpat" varpat)
	      (debug "translpat_orpat.varhandler varmdata" varmdata)
	      (assert_msg "check varpat" (is_a varpat class_source_pattern_variable))
	      (assert_msg "check varmdata" (is_a varmdata class_matched_data))
	      (if (null varsymbval)
		  (progn
		    (mapobject_put newvarmap (get_field :spatvar_symb varpat)
				   varmdata)
		    (debug "translpat_orpat.varhandler updated newvarmap" newvarmap)
		    ))
	      ))
	   )
       (list_prepend mhandlers varhandler)
       (debug "translpat_orpat curdisj before translate_pattern" curdisj)
       (multicall 
	(disjstep disjflag)
	(translate_pattern curdisj mdata mcase varmap sloc)
	(debug "translpat_orpat disjstep" disjstep)
	(debug "translpat_orpat disjflag" disjflag)
	(if disjflag
	    (list_append flaglist disjflag))
	(if disjstep
	    (progn 
	      (cond 
	       ( (is_a prevstep class_match_step_clear)
		 (debug "translpat_orpat prevstep clear so putthen prevstep=" prevstep)
		 (put_then_match prevstep disjstep))
	       ( prevstep
		 (debug "translpat_orpatnotnull so putelse  prevstep=" prevstep)
		 (put_else_match prevstep disjstep)))
	      (if (>i (mapobject_count newvarmap) 0)
		  (let ( 
			(sortedsymbs (mapobject_sorted_attribute_tuple newvarmap))
			(sortedmdatas
			 (multiple_map 
			  sortedsymbs
			  (lambda (cursymb :long symbix)
			    (mapobject_get newvarmap cursymb)) 
			  ))
			(erasestep (instance class_match_step_clear
					     :loca_location (get_field :loca_location disjstep)
					     :mstep_then ()
					     :mstep_cleardata sortedmdatas
					     )
				   )
			)
		    (debug "translpat_orpat disjstep=" disjstep "\n.. erasestep=" erasestep)
		    (put_else_match disjstep erasestep)
		    (setq prevstep erasestep)
		    (debug "translpat_orpat prevstep is erasestep" prevstep)
		    )
		(progn
		  (setq prevstep disjstep)
		  (debug "translpat_orpat prevstep is disjstep" prevstep)
		  ))
	      (list_append steplist disjstep)
	      ))
	)
       (debug "translpat_orpat newvarmap" newvarmap)
       (let ( (oldvarhdler (list_popfirst mhandlers)) 
	      )
	 (assert_msg "check oldvarhdler" (== oldvarhdler varhandler))
	 ))
     ) ;;;; end foreach disjunct
    (debug "translpat_orpat final steplist" steplist)
    (put_fields stepgroup
		:mstgroup_start firststep
		:mstgroup_then (list_to_multiple steplist)
		:mstgroup_else ()
		)
    (debug "translpat_orpat final flaglist" flaglist)
    (put_fields flagstep :mstep_flagargs (list_to_multiple flaglist discr_multiple))
    (debug "translpat_orpat final flagstep" flagstep)
    (put_then_match stepgroup flagstep)
    (debug "translpat_orpat return stepgroup" stepgroup)
    (return stepgroup mflag)
    ))
(install_method class_source_pattern_or translate_pattern translpat_orpat)



;;;;;;;;;;;;;;;;
;; translation of pattern matchers (c-matchers or fun-matchers)
(defun translpat_patmat (recv mdata mcase varmap psloc)
  (debug "translpat_patmat recv" recv)
  (assert_msg "check recv" (is_a recv class_source_pattern_matcher))
  (debug "translpat_patmat mdata" mdata)
  (assert_msg "check mdata" (is_a mdata class_matched_data))
  (debug "translpat_patmat mcase" mcase)
  (assert_msg "check mcase" (is_a mcase class_match_case))
  (let (
	(sloc (or (unsafe_get_field :loca_location recv) psloc))
	(sopbind (unsafe_get_field :spac_operbind recv))
	(soper (unsafe_get_field :spac_operator recv))
	(sins (unsafe_get_field :spac_inargs recv))
	(souts (unsafe_get_field :spac_outargs recv))
	(matctx (unsafe_get_field  :mcase_mctxt mcase))
	(env (get_field :mctx_env matctx))
	(ncx (get_field :mctx_normctxt matctx))
	(opin (get_field :amatch_in soper))
	(opout (get_field :amatch_out soper))
	(:long nbopout (multiple_length opout))
	(curstep ())
	(mdatasteps (get_field :mdata_steps mdata))
	(mflag (make_match_flag recv matctx (get_field :named_name soper)))
	)
    (assert_msg "check matctx" (is_a matctx class_matching_context))
    (assert_msg "check env" (is_a env class_environment))
    (assert_msg "check mdatasteps list" (is_list mdatasteps))
    (debug "translpat_patmat soper" soper)
    (assert_msg "check soper" (is_a soper class_any_matcher))
    (debug "translpat_patmat sins" sins)
    (debug "translpat_patmat souts" souts)
    (debug "translpat_patmat sopbind" sopbind)
    (multicall
     (nins inbinds)
     (normalize_tuple sins env ncx sloc)
     (debug "translpat_patmat nins" nins)
     (debug "translpat_patmat inbinds" inbinds)
     (assert_msg "check inbinds" (is_list_or_null inbinds))
     (if (!=i (multiple_length nins) (multiple_length opin))
	 (error_strv sloc "bad input arity of matcher in pattern" 
		     (get_field :named_name soper)))
     (foreach_in_multiple
      (nins)
      (curnin :long nix)
      (let ( (curopin (multiple_nth opin nix))
	     (curctyp (get_ctype curnin env))
	     (inctyp (get_field :fbind_type curopin))
	     )
	(debug "translpat_patmat curnin" curnin)
	(debug "translpat_patmat curopin" curopin)
	(debug "translpat_patmat curctyp" curctyp)
	(assert_msg "check curopin" (is_a curopin class_formal_binding))
	(assert_msg "check curctyp" (is_a curctyp class_ctype))
	(if (!= curctyp inctyp)
	    (progn
	      (error_strv sloc "bad input type in matcher, expecting"
			  (get_field :named_name inctyp))
	      (error_strv sloc
			  "mistyped formal name in matcher is"
			  (get_field  :named_name (get_field :binder curopin)))
	      (error_strv sloc "got input type in matcher" 
			  (get_field :named_name curctyp))
	      (return)))
	))
     ;; try to find the same test step, and the last test for this mdata
     (let (
	   (laststeptest ())
	   )
       (foreach_pair_component_in_list
	(mdatasteps)
	(curpairstep curdatastep)
	(assert_msg "check curdatastep" (is_a curdatastep class_match_step))
	(if (is_a curdatastep class_match_step_test)
	    (setq laststeptest curdatastep))
	(if (and
	     (is_a curdatastep class_match_step_test_matcher)
	     (== (get_field :mstep_data curdatastep) mdata)
	     (== (unsafe_get_field :mstma_matcher curdatastep) soper)
	     (==i (list_length inbinds) 0)
	     (==i (list_length (unsafe_get_field :mstma_binds curdatastep)) 0)
	     )
	    (let ( (similarstep curdatastep)
		   (curins (unsafe_get_field :mstma_ins curdatastep))
		   )
	      (foreach_in_multiple
	       (curins)
	       (cursimin :long simix)
	       (if (!= (multiple_nth nins simix) cursimin)
		   (progn
		     (setq simix -1)
		     (setq cursimin ())
		     (setq similarstep ())))
	       )
	      (debug "translpat_patmat similiarstep" similarstep)
	      (if similarstep 
		  (progn
		    (setq curstep similarstep)
		    (setq curpairstep ())
		    (setq curdatastep ())))
	      ))
	)
       (debug "translpat_patmat custep after seeking" curstep)
       (if (null curstep)
	   (let ( 
		 (outdatatup (make_multiple discr_multiple nbopout))
		 (newstep (instance class_match_step_test_matcher
				    :loca_location sloc
				    :mstep_data mdata
				    :mstep_then ()
				    :mstep_else ()
				    :mstma_matcher soper
				    :mstma_binds inbinds
				    :mstma_ins nins
				    :mstma_outs outdatatup))
		 )
	     (setq curstep newstep)
	     (debug "translpat_patmat newstep" newstep)
	     (list_append mdatasteps newstep)
	     (debug "translpat_patmat updated mdatasteps" mdatasteps)
	     (if laststeptest
		 (progn
		   (put_else_match laststeptest newstep)
		   (debug "translpat_patmat updated laststeptest" laststeptest)))
	     (foreach_in_multiple
	      (opout)
	      (curoutbind :long outix)
	      (debug "translpat_patmat curoutbind" curoutbind)
	      (assert_msg "check curoutbind" (is_a curoutbind class_formal_binding))
	      (let ( (outsymb (get_field :binder curoutbind))
		     (outctyp (get_field :fbind_type curoutbind))
		     (newslot (instance class_matched_data
					:mdata_symb (clone_symbol outsymb)
					:mdata_ctype outctyp
					:mdata_orig newstep
					:mdata_steps (make_list discr_list)))
		     )
		(debug "translpat_patmat outsymb" outsymb)
		(debug "translpat_patmat newslot" newslot)
		(multiple_put_nth outdatatup outix newslot)
		(assert_msg "check outctyp" (is_a outctyp class_ctype))
		))
	     ))
       (debug "translpat_patmat curstep after making it" curstep)
       (assert_msg "check curstep" (is_a curstep class_match_step_test_matcher))
       (debug "translpat_patmat souts again" souts)
       (let ( 
	     (outdata (get_field :mstma_outs curstep))
	     (thenlist (make_list discr_list))
	     (elselist (make_list discr_list))
	     (flaglist (make_list discr_list))
	     (laststep curstep)
	     (testgroup (instance class_match_step_test_group
				  :loca_location sloc
				  :mstep_data mdata
				  :mstep_then ()
				  :mstep_else ()
				  :mstgroup_start curstep
				  :mstgroup_then ()
				  :mstgroup_else ()
				  ))
	     )
	 (debug "translpat_patmat outdata before foreach" outdata)
	 (debug "translpat_patmat souts before foreach" souts)
	 (foreach_in_multiple
	  (outdata)
	  (curoutdata :long dix)
	  (let ( (outpat (multiple_nth souts dix))
		 )
	    (debug "translpat_patmat curoutdata" curoutdata)
	    (debug "translpat_patmat outpat" outpat)
	    (multicall 
	     (outstep outflag)
	     (translate_pattern outpat curoutdata mcase varmap sloc)
	     (debug "translpat_patmat outstep" outstep)
	     (debug "translpat_patmat outflag" outflag)
	     (if outstep
		 (progn
		   (put_then_match laststep outstep)
		   (list_append elselist outstep)
		   (setq laststep outstep)
		   ))
	     (if outflag
		 (progn
		   (assert_msg "check outflag" (is_a outflag class_match_flag))
		   (list_append flaglist outflag))
	       ))))
	 (let ( (flagstep
		 (if (list_first_element flaglist)
		     (instance class_match_step_flag_conjunction
			       :loca_location sloc
			       :mstep_then ()
			       :mstep_flag mflag
			       :mstep_flagargs (list_to_multiple flaglist discr_multiple)
			       )
		   (instance class_match_step_flag_set
			     :loca_location sloc
			     :mstep_then ()
			     :mstep_flag mflag
			     )
		     )
		 )
		)
	   (debug "translpat_patmat flagstep" flagstep)
	   (if laststep (put_then_match laststep flagstep))
	   (put_fields mflag :mflag_setstep flagstep)
	   (put_fields
	    testgroup
	    :mstgroup_then flagstep
	    :mstgroup_else elselist)
	   (debug "translpat_patmat return mflag" mflag)
	   (debug "translpat_patmat return testgroup" testgroup)
	   (return testgroup mflag)
	   )
	 )	    
       )
     )
    )
  )

(install_method class_source_pattern_matcher  translate_pattern translpat_patmat)
	

;; internal selector to output the label of a test in "HTML-like"
;; graphiz format
(defselector matchgraphic_altstep class_selector
)


(defun mgaltstep_any (recv mg)
  (let ( (dis (discrim recv))
	 )
  (debug "mgaltstep_any recv=" recv " mg=" mg " for discrim=" dis)
  (errormsg_strv "unexpected MATCHGRAPHIC_ALTSTEP for " (get_field :named_name dis))
  (assert_msg "@$@unexpected MATCHGRAPHIC_ALTSTEP [mgaltstep_any]")
))
(install_method class_root matchgraphic_altstep mgaltstep_any)


;;;;;;;;;;;;;;;;
(defun mgaltstep_steptestvar (step mg)
  (debug "mgaltstep_steptestvar step" step)
  (assert_msg "check step" (is_a step class_match_step_test_variable))
  (assert_msg "check mg" (is_a mg class_match_graphic))
  (let ( (loca (unsafe_get_field :loca_location step))
	 (sthen (unsafe_get_field :mstep_then step))
	 (selse (unsafe_get_field :mstep_else step))
	 (testdata (unsafe_get_field :msteptestvar_data step))
	 (nodebuf (unsafe_get_field :mchgx_nodout mg))
	 (edgebuf (unsafe_get_field :mchgx_edgout mg))
	 (datamap (unsafe_get_field :mchgx_datanamemap mg))
	 (stepmap (unsafe_get_field :mchgx_stepnamemap mg))
	 (stepname (mapobject_get stepmap step))
	 (thenname (if sthen (mapobject_get stepmap sthen)))
	 (elsename (if selse (mapobject_get stepmap selse)))
	 (:long stephash (obj_hash step))
	 (dis (discrim step))
	 (clanam (get_field :named_name dis))
	 )
    (add2out_strconst nodebuf "<tr><td><font color=\"royalblue4\" face=\"Times-Roman Bold\" point-size=\"6\">")
    (code_chunk 
     outclanam
     #{ /* $OUTCLANAM */
     meltgc_add_out ((melt_ptr_t) $NODEBUF,
		     melt_string_str ((melt_ptr_t) $CLANAM) +6)	;
     }#)
    (add2out_strconst nodebuf "</font></td> <td>")
    (add2out_strconst nodebuf "<font face=\"Helvetica Italic\" color=\"darkgreen\" point-size=\"6.5\">")
    (add2sbuf_short_mixloc nodebuf loca)
    (add2out_strconst nodebuf "</font></td> </tr>")
    (add2out_indentnl nodebuf 0)
    (add2out_strconst nodebuf "<tr><td colspan=\"2\"><font face=\"Time-Roman Italics\" point-size=\"7\" color=\"navy\">")
    (compile_warning "testdata is usually not a symbol but a matched data...")
    (debug "mgaltstep_steptestvar testdata" testdata)
    (let ( (testdatasymb (get_field :mdata_symb testdata)) 
	   )
    (add2out_string nodebuf (get_field :named_name testdatasymb))
    (if (is_a testdatasymb class_cloned_symbol)
	(let ( (:long syrank (get_int (get_field :csym_urank testdatasymb)))
	      )
	  (add2out_strconst nodebuf "$")
	  (add2out_longdec nodebuf syrank)
	  )))
    (add2out_strconst nodebuf "</font></td> </tr>")
    (add2out_indentnl nodebuf 0)
    (if thenname
	(progn
	  (add2out_indentnl edgebuf 0)
	  (add2out_string edgebuf stepname)
	  (add2out_strconst edgebuf " /*then*/ -> ")
	  (add2out_string edgebuf thenname)
	  (add2out_strconst edgebuf " [ arrowhead=normal, color=green ];")
	  ))
    (if elsename
	(progn
	  (add2out_indentnl edgebuf 0)
	  (add2out_string edgebuf stepname)
	  (add2out_strconst edgebuf " /*else*/ -> ")
	  (add2out_string edgebuf elsename)
	  (add2out_strconst edgebuf " [ arrowhead=diamond, color=red ];")
	  ))
    ))
(install_method class_match_step_test_variable matchgraphic_altstep mgaltstep_steptestvar)


;;;;;;;;;;;;;;;;
(defun mgaltstep_steptestinst (step mg)
  (debug "mgaltstep_steptestinst step" step)
  (assert_msg "check step" (is_a step class_match_step_test_instance))
  (assert_msg "check mg" (is_a mg class_match_graphic))
  (let ( (loca (unsafe_get_field :loca_location step))
	 (sthen (unsafe_get_field :mstep_then step))
	 (selse (unsafe_get_field :mstep_else step))
	 (testclass (unsafe_get_field :mstins_class step))
	 (testslots (unsafe_get_field :mstins_slots step))
	 (nodebuf (unsafe_get_field :mchgx_nodout mg))
	 (edgebuf (unsafe_get_field :mchgx_edgout mg))
	 (datamap (unsafe_get_field :mchgx_datanamemap mg))
	 (stepmap (unsafe_get_field :mchgx_stepnamemap mg))
	 (stepname (mapobject_get stepmap step))
	 (thenname (if sthen (mapobject_get stepmap sthen)))
	 (elsename (if selse (mapobject_get stepmap selse)))
	 (:long stephash (obj_hash step))
	 (dis (discrim step))
	 (clanam (get_field :named_name dis))
	 )
    (add2out_strconst nodebuf "<tr><td><font color=\"salmon4\" face=\"Times-Roman Bold\" point-size=\"6\">")
    (code_chunk 
     outclanam
     #{ /* $OUTCLANAM */
     meltgc_add_out ((melt_ptr_t) $NODEBUF,
		     melt_string_str ((melt_ptr_t) $CLANAM) +6)	;
     }#)
    (add2out_strconst nodebuf "</font></td> <td>")
    (add2out_strconst nodebuf "<font face=\"Helvetica Italic\" color=\"darkgreen\" point-size=\"6.5\">")
    (add2sbuf_short_mixloc nodebuf loca)
    (add2out_strconst nodebuf "</font></td> </tr>")
    (add2out_indentnl nodebuf 0)
    (add2out_strconst nodebuf "<tr><td colspan=\"2\"><font color=\"salmon\" face=\"Helvetica Oblique\" point-size=\"6\">")
    (add2out_string nodebuf (get_field :named_name testclass))
    (add2out_strconst nodebuf "</font></td> </tr>")
    (add2out_indentnl nodebuf 0)
    (foreach_in_multiple
     (testslots)
     (curslot :long slix)
     (if curslot
	 (progn
	   (assert_msg "check curslot" (is_a curslot class_matched_data))
	   (let ( 
		 (curslotdata  (mapobject_get datamap curslot))
		 (fld (multiple_nth (get_field :class_fields testclass) slix))
		 (fldname (get_field :named_name fld))
		 )
	   (add2out_indentnl edgebuf 0)
	   (assert_msg "check fld" (is_a fld class_field))
	   (add2out edgebuf ##{$STEPNAME /* testinslot */ -> /*data*/ $CURSLOTDATA 
      [ arrowhead=open, label=<<font point-size="6.5" color="indigo">$FLDNAME</font>>,  color=violet, style=dotted ];
		    }#)
	     )
	   ))
     )
    (if thenname
	(progn
	  (add2out_indentnl edgebuf 0)
	  (add2out edgebuf ##{$STEPNAME /*then*/ -> $THENNAME  [ arrowhead=normal, color=green ];}#
		   )))
    (if elsename
	(progn
	  (add2out_indentnl edgebuf 0)
	  (add2out edgebuf ##{$STEPNAME /*then*/ -> $ELSENAME  [ arrowhead=diamond, color=red ];}#
		   )))
    ))
(install_method class_match_step_test_instance matchgraphic_altstep mgaltstep_steptestinst)


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

(defun mgaltstep_steptestmult (step mg)
  (debug "mgaltstep_steptestmult step=" step)
  (assert_msg "check step" (is_a step class_match_step_test_multiple))
  (assert_msg "check mg" (is_a mg class_match_graphic))
  (let ( (loca (unsafe_get_field :loca_location step))
	 (nodebuf (unsafe_get_field :mchgx_nodout mg))
	 (edgebuf (unsafe_get_field :mchgx_edgout mg))
	 (sthen (unsafe_get_field :mstep_then step))
	 (selse (unsafe_get_field :mstep_else step))
	 (sdata (unsafe_get_field :mstep_data step))
	 (sindex (unsafe_get_field :mstep_index step))
	 (scomp (unsafe_get_field :msttup_components step))
	 (datamap (unsafe_get_field :mchgx_datanamemap mg))
	 (stepmap (unsafe_get_field :mchgx_stepnamemap mg))
	 (stepname (mapobject_get stepmap step))
	 (thenname (if sthen (mapobject_get stepmap sthen)))
	 (elsename (if selse (mapobject_get stepmap selse)))
	 (:long stephash (obj_hash step))
	 (:long nbcomp (multiple_length scomp))
	 (dis (discrim step))
	 (clanam (get_field :named_name dis))
	 )
    (add2out_strconst nodebuf "<tr><td><font color=\"hotpink\" face=\"Times-Roman Bold\" point-size=\"6\">")
    (code_chunk 
     outclanam
     #{ /* $OUTCLANAM */
     meltgc_add_out ((melt_ptr_t) $NODEBUF,
		     melt_string_str ((melt_ptr_t) $CLANAM) +6)	;
     }#)
    (add2out nodebuf ##{</font>  <font color="red" face="Courier" point-size="6">^$NBCOMP</font></td>}#)
    (add2out_strconst nodebuf "<td>")
    (add2out_strconst nodebuf "<font face=\"Helvetica Italic\" color=\"darkgreen\" point-size=\"6.5\">")
    (add2sbuf_short_mixloc nodebuf loca)
    (add2out_strconst nodebuf "</font></td> </tr>")
    (add2out_indentnl nodebuf 0)
    ;;
    (debug "mgaltstep_steptestmult scomp=" scomp)
    (foreach_in_multiple
     (scomp)
     (curcomp :long cpix)
     (debug "mgaltstep_steptestmult curcomp=" curcomp " cpix=" cpix)
     (if curcomp
	 (progn
	   (assert_msg "check curcomp" (is_a curcomp class_matched_data))
	   (let ( 
		 (curcompdata  (mapobject_get datamap curcomp))
		 )
	     (debug "mgaltstep_steptestmult curcompdata=" curcompdata " cpix=" cpix)
	     (if (null curcompdata) (debug "mgaltstep_steptestmult bad datamap=" datamap " for curcomp=" curcomp))
	     (assert_msg "check curcompdata" curcompdata)
	     (add2out_indentnl edgebuf 0)
	     (add2out edgebuf ##{$STEPNAME /* testtuplcomp */ -> /*data*/ $CURCOMPDATA 
    [ arrowhead=open, label=<<font point-size="6.5" color="indigo">[$CPIX]</font>>,  color=violet, style=dotted ];
		      }#)
	     ))))
    ;;
    (if thenname
	(progn
	  (add2out_indentnl edgebuf 0)
	  (add2out edgebuf ##{$STEPNAME /*then*/ -> $THENNAME [ arrowhead=normal, color=green ];}#
		   )))
    (if elsename
	(progn
	 (add2out_indentnl edgebuf 0)
	 (add2out edgebuf ##{$STEPNAME /*else*/ -> $ELSENAME  [ arrowhead=diamond, color=red ];}#
		  )))
    ))
(install_method class_match_step_test_multiple matchgraphic_altstep mgaltstep_steptestmult)

;;;;;;;;;;;;;;;;
(defun mgaltstep_steptestgroup (step mg)
  (debug "mgaltstep_steptestgroup step" step)
  (assert_msg "check step" (is_a step class_match_step_test_group))
  (assert_msg "check mg" (is_a mg class_match_graphic))
  (let ( (loca (unsafe_get_field :loca_location step))
	 (sthen (unsafe_get_field :mstep_then step))
	 (selse (unsafe_get_field :mstep_else step))
	 (nodebuf (unsafe_get_field :mchgx_nodout mg))
	 (edgebuf (unsafe_get_field :mchgx_edgout mg))
	 (datamap (unsafe_get_field :mchgx_datanamemap mg))
	 (stepmap (unsafe_get_field :mchgx_stepnamemap mg))
	 (stepname (mapobject_get stepmap step))
	 (thenname (if sthen (mapobject_get stepmap sthen)))
	 (elsename (if selse (mapobject_get stepmap selse)))
	 (:long stephash (obj_hash step))
	 (dis (discrim step))
	 (clanam (get_field :named_name dis))
	 )
    (add2out_strconst nodebuf "<tr><td><font color=\"hotpink\" face=\"Times-Roman Bold\" point-size=\"6\">")
    (code_chunk 
     outclanam
     #{ /* $OUTCLANAM */
     meltgc_add_out ((melt_ptr_t) $NODEBUF,
		     melt_string_str ((melt_ptr_t) $CLANAM) +6)	;
     }#)
    (add2out_strconst nodebuf "</font></td> <td>")
    (add2out_strconst nodebuf "<font face=\"Helvetica Italic\" color=\"darkgreen\" point-size=\"6.5\">")
    (add2sbuf_short_mixloc nodebuf loca)
    (add2out_strconst nodebuf "</font></td> </tr>")
    (add2out_indentnl nodebuf 0)
    (if thenname
	(progn
	  (add2out_indentnl edgebuf 0)
	  (add2out edgebuf ##{$STEPNAME /*then*/ -> $THENNAME [ arrowhead=normal, color=green ];}#
		   )))
    (if elsename
	(progn
	 (add2out_indentnl edgebuf 0)
	 (add2out edgebuf ##{$STEPNAME /*else*/ -> $ELSENAME  [ arrowhead=diamond, color=red ];}#
		  )))
    ))
(install_method class_match_step_test_group matchgraphic_altstep mgaltstep_steptestgroup)

;;;;;;;;;;;;;;;;
(defun mgaltstep_steptestmatcher (step mg)
  (debug "mgaltstep_steptestmatcher step" step)
  (assert_msg "check step" (is_a step class_match_step_test_matcher))
  (assert_msg "check mg" (is_a mg class_match_graphic))
  (let ( (loca (unsafe_get_field :loca_location step))
	 (sthen (unsafe_get_field :mstep_then step))
	 (selse (unsafe_get_field :mstep_else step))
	 (smatcher (unsafe_get_field :mstma_matcher step))
	 (souts (unsafe_get_field :mstma_outs step))
	 (nodebuf (unsafe_get_field :mchgx_nodout mg))
	 (edgebuf (unsafe_get_field :mchgx_edgout mg))
	 (datamap (unsafe_get_field :mchgx_datanamemap mg))
	 (stepmap (unsafe_get_field :mchgx_stepnamemap mg))
	 (stepname (mapobject_get stepmap step))
	 (thenname (if sthen (mapobject_get stepmap sthen)))
	 (elsename (if selse (mapobject_get stepmap selse)))
	 (:long stephash (obj_hash step))
	 (dis (discrim step))
	 (clanam (get_field :named_name dis))
	 )
    (add2out_strconst nodebuf "<tr><td><font color=\"peru\" face=\"Times-Roman Bold\" point-size=\"6\">")
    (code_chunk 
     outclanam
     #{ /* $OUTCLANAM */
     meltgc_add_out ((melt_ptr_t) $NODEBUF,
		     melt_string_str ((melt_ptr_t) $CLANAM) +6)	;
     }#)
    (add2out_strconst nodebuf "</font></td> <td>")
    (add2out_strconst nodebuf "<font face=\"Helvetica Italic\" color=\"darkgreen\" point-size=\"6.5\">")
    (add2sbuf_short_mixloc nodebuf loca)
    (add2out_strconst nodebuf "</font></td> </tr>")
    (add2out_indentnl nodebuf 0)
    (add2out_strconst nodebuf "<tr><td colspan=\"2\"><font color=\"peru\" face=\"Time-Roman Italics\" point-size=\"7\">")
    (add2out_string nodebuf (get_field :named_name smatcher))
    (add2out_strconst nodebuf "</font></td> </tr>")
    (add2out_indentnl nodebuf 0)
    (foreach_in_multiple
     (souts)
     (curout :long outix)
     (debug "mgaltstep_steptestmatcher curout" curout)
     (assert_msg "check curout" (is_a curout class_matched_data))
     (add2out_indentnl edgebuf 0)
     (add2out_string edgebuf stepname)
     (add2out_strconst edgebuf " /*matchstep*/ -> /*data*/ ")
     (add2out_string edgebuf (mapobject_get datamap curout))
     (add2out_strconst edgebuf " [ arrowhead=open, ")
     (let ( (outbind (multiple_nth (get_field :amatch_out smatcher) outix))
	    (outsymb (get_field :binder outbind))
	    )
       (if (is_a outsymb class_symbol)
	   (progn
	     (add2out_strconst edgebuf " label=<<font face=\"Helvetica\" point-size=\"6\">")
	     (add2out_string edgebuf (get_field :named_name outsymb))
	     (add2out_strconst edgebuf "</font>>, "))))
     (add2out_strconst edgebuf " color=violet, style=dotted ];")
     )
    (if thenname
	(progn
	  (add2out_indentnl edgebuf 0)
	  (add2out_string edgebuf stepname)
	  (add2out_strconst edgebuf " /*then*/ -> ")
	  (add2out_string edgebuf thenname)
	  (add2out_strconst edgebuf " [ arrowhead=normal, color=green ];")
	  ))
    (if elsename
	(progn
	  (add2out_indentnl edgebuf 0)
	  (add2out_string edgebuf stepname)
	  (add2out_strconst edgebuf " /*else*/ -> ")
	  (add2out_string edgebuf elsename)
	  (add2out_strconst edgebuf " [ arrowhead=diamond, color=red ];")
	  ))
    ))
(install_method class_match_step_test_matcher matchgraphic_altstep mgaltstep_steptestmatcher)


;;;;;;;;;;;;;;;;
(defun mgaltstep_stepsuccess (step mg)
  (debug "mgaltstep_stepsuccess step" step)
  (assert_msg "check step" (is_a step class_match_step_success_when_flag))
  (assert_msg "check mg" (is_a mg class_match_graphic))
  (let ( (loca (unsafe_get_field :loca_location step))
	 (sthen (unsafe_get_field :mstep_then step))
	 (sflag (unsafe_get_field :mstep_flag step))
	 (nodebuf (unsafe_get_field :mchgx_nodout mg))
	 (edgebuf (unsafe_get_field :mchgx_edgout mg))
	 (datamap (unsafe_get_field :mchgx_datanamemap mg))
	 (stepmap (unsafe_get_field :mchgx_stepnamemap mg))
	 (stepname (mapobject_get stepmap step))
	 (thenname (if sthen (mapobject_get stepmap sthen)))
	 (:long stephash (obj_hash step))
	 (flagrank (get_field :mflag_rank sflag))
	 (flagstring (get_field :mflag_string sflag))
	 (flagloc (get_field :loca_location sflag))
	 (argfstep (get_field :mflag_setstep sflag))
	 (dis (discrim step))
	 (clanam (get_field :named_name dis))
	 )
    (debug "mgaltstep_stepsuccess sflag" sflag)
    (assert_msg "check sflag" (is_a sflag class_match_flag))
    (add2out_strconst nodebuf "<tr><td><font color=\"firebrick\" face=\"Times-Roman Bold\" point-size=\"6\">")
    (code_chunk 
     outclanam
     #{ /* $OUTCLANAM */
     meltgc_add_out ((melt_ptr_t) $NODEBUF,
		     melt_string_str ((melt_ptr_t) $CLANAM) +6)	;
     }#)
    (add2out_strconst nodebuf "</font></td> <td>")
    (add2out_strconst nodebuf "<font face=\"Helvetica Italic\" color=\"darkgreen\" point-size=\"6.5\">")
    (add2sbuf_short_mixloc nodebuf loca)
    (add2out_strconst nodebuf "</font></td> </tr>")
    (add2out_indentnl nodebuf 0)
    (add2out_strconst nodebuf "<tr><td><font color=\"turquoise4\" face=\"Times-Roman\" point-size=\"7\">flag#")
    (add2out_longdec nodebuf (get_int flagrank))
    (add2out_strconst nodebuf " ")
    (add2out_string nodebuf flagstring)
    (add2out_strconst nodebuf "</font></td> <td><font face=\"Helvetiva Italic\" color=\"olivedrab\" point-size=\"6.5\">")
    (add2sbuf_short_mixloc nodebuf flagloc)
    (add2sbuf_strconst nodebuf "</font></td> </tr>")
    (add2out_indentnl nodebuf 0)
    (if thenname
	(progn
	  (add2out_indentnl edgebuf 0)
	  (add2out_string edgebuf stepname)
	  (add2out_strconst edgebuf " /*then*/ -> ")
	  (add2out_string edgebuf thenname)
	  (add2out_strconst edgebuf " [ arrowhead=normal, color=green ];")
	  ))
    (if (is_a argfstep class_match_step_with_flag)
	(let ( (argfstepname (mapobject_get stepmap argfstep))
	       )
	  (debug "mgaltstep_stepsuccess argfstep" argfstep)
	  (debug "mgaltstep_stepsuccess argfstepname" argfstepname)
	  (assert_msg "mgaltstep_stepsuccess check argfstepname" (is_string argfstepname))
	  (add2out_indentnl edgebuf 0)
	  (add2out_string edgebuf argfstepname)
	  (add2out_strconst edgebuf " /*argflag suc*/ -> ")
	  (add2out_string edgebuf stepname)
	  (add2out_strconst edgebuf " [ arrowhead=olnormal, color=chartreuse2, style=dotted ];")
	  ))
    ))

(install_method class_match_step_success_when_flag  matchgraphic_altstep mgaltstep_stepsuccess)
;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;
(defun mgaltstep_stepclear (step mg)
  (debug "mgaltstep_stepclear step" step)
  (assert_msg "check step" (is_a step class_match_step_clear))
  (assert_msg "check mg" (is_a mg class_match_graphic))
  (let ( (loca (unsafe_get_field :loca_location step))
	 (sthen (unsafe_get_field :mstep_then step))
	 (scleardata (unsafe_get_field :mstep_cleardata step))
	 (nodebuf (unsafe_get_field :mchgx_nodout mg))
	 (edgebuf (unsafe_get_field :mchgx_edgout mg))
	 (datamap (unsafe_get_field :mchgx_datanamemap mg))
	 (stepmap (unsafe_get_field :mchgx_stepnamemap mg))
	 (stepname (mapobject_get stepmap step))
	 (thenname (if sthen (mapobject_get stepmap sthen)))
	 (:long stephash (obj_hash step))
	 (dis (discrim step))
	 (clanam (get_field :named_name dis))
	 )
    (add2out_strconst nodebuf "<tr><td><font color=\"SaddleBrown\" face=\"Times-Roman Bold\" point-size=\"6\">")
    (code_chunk 
     outclanam
     #{ /* $OUTCLANAM */
     meltgc_add_out ((melt_ptr_t) $NODEBUF,
		     melt_string_str ((melt_ptr_t) $CLANAM) +6)	;
     }#)
    (add2out_strconst nodebuf "</font></td> <td>")
    (add2out_strconst nodebuf "<font face=\"Helvetica Italic\" color=\"darkgreen\" point-size=\"6.5\">")
    (add2sbuf_short_mixloc nodebuf loca)
    (add2out_strconst nodebuf "</font></td> </tr>")
    (add2out_indentnl nodebuf 0)
    (add2out_strconst nodebuf "<tr><td><font color=\"LimeGreen\" face=\"Times-Roman Bold\" point-size=\"6\">")
    (foreach_in_multiple
     (scleardata)
     (curcdata :long cix)
     (if (>i cix 0) (add2out_strconst nodebuf " "))
     (let ( (cdatanam  (mapobject_get datamap curcdata)) 
	    )
       (add2out_string nodebuf cdatanam)
       (add2out_indentnl edgebuf 0)
       (add2out_string edgebuf cdatanam)
       (add2out_strconst edgebuf " /*cleared data*/ -> ")
       (add2out_string edgebuf stepname)
       (add2out_strconst edgebuf " [ arrowhead=open,")
       (add2out_strconst edgebuf " color=violet, style=dotted ];")
     ))
    (add2out_strconst nodebuf "</font></td> </tr>")
    (add2out_indentnl nodebuf 0)
    (if thenname
	(progn
	  (add2out_indentnl edgebuf 0)
	  (add2out_string edgebuf stepname)
	  (add2out_strconst edgebuf " /*then*/ -> ")
	  (add2out_string edgebuf thenname)
	  (add2out_strconst edgebuf " [ arrowhead=normal, color=green ];")
	  ))
    ))
(install_method class_match_step_clear matchgraphic_altstep mgaltstep_stepclear)

(defun mgaltstep_stepflagset (step mg)
  (debug "mgaltstep_stepflagset step" step)
  (assert_msg "check step" (is_a step class_match_step_flag_set))
  (assert_msg "check mg" (is_a mg class_match_graphic))
  (let ( (loca (unsafe_get_field :loca_location step))
	 (sthen (unsafe_get_field :mstep_then step))
	 (sflag (unsafe_get_field :mstep_flag step))
	 (nodebuf (unsafe_get_field :mchgx_nodout mg))
	 (edgebuf (unsafe_get_field :mchgx_edgout mg))
	 (datamap (unsafe_get_field :mchgx_datanamemap mg))
	 (stepmap (unsafe_get_field :mchgx_stepnamemap mg))
	 (stepname (mapobject_get stepmap step))
	 (thenname (if sthen (mapobject_get stepmap sthen)))
	 (:long stephash (obj_hash step))
	 (dis (discrim step))
	 (clanam (get_field :named_name dis))
	 (flagrank (get_field :mflag_rank sflag))
	 (flagstring (get_field :mflag_string sflag))
	 (flagloc (get_field :loca_location sflag))
	 )
    (add2out_strconst nodebuf "<tr><td><font color=\"darkolivegreen4\" face=\"Times-Roman Bold\" point-size=\"6\">")
    (code_chunk 
     outclanam
     #{ /* $OUTCLANAM */
     meltgc_add_out ((melt_ptr_t) $NODEBUF,
		     melt_string_str ((melt_ptr_t) $CLANAM) +6)	;
     }#)
    (add2out_strconst nodebuf "</font></td> <td>")
    (add2out_strconst nodebuf "<font face=\"Helvetica Italic\" color=\"darkgreen\" point-size=\"6.5\">")
    (add2sbuf_short_mixloc nodebuf loca)
    (add2out_strconst nodebuf "</font></td> </tr>")
    (add2out_indentnl nodebuf 0)
    (add2out_strconst nodebuf "<tr><td><font color=\"turquoise4\" face=\"Times-Roman\" point-size=\"7\">flag#")
    (add2out_longdec nodebuf (get_int flagrank))
    (add2out_strconst nodebuf " ")
    (add2out_string nodebuf flagstring)
    (add2out_strconst nodebuf "</font></td> <td><font face=\"Helvetiva Italic\" color=\"olivedrab\" point-size=\"6.5\"> ")
    (add2sbuf_short_mixloc nodebuf flagloc)
    (add2sbuf_strconst nodebuf "</font></td> </tr>")
    (add2out_indentnl nodebuf 0)
    (if thenname
	(progn
	  (add2out_indentnl edgebuf 0)
	  (add2out_string edgebuf stepname)
	  (add2out_strconst edgebuf " /*then*/ -> ")
	  (add2out_string edgebuf thenname)
	  (add2out_strconst edgebuf " [ arrowhead=normal, color=green ];")
	  ))
    ))

(install_method class_match_step_flag_set matchgraphic_altstep mgaltstep_stepflagset)
;;;;;;;;;;;;;;;;
(defun mgaltstep_stepflagoper (step mg)
  (debug "mgaltstep_stepflagoper step" step)
  (assert_msg "check step" (is_a step class_match_step_flag_operation))
  (assert_msg "check mg" (is_a mg class_match_graphic))
  (let ( (loca (unsafe_get_field :loca_location step))
	 (sthen (unsafe_get_field :mstep_then step))
	 (sflag (unsafe_get_field :mstep_flag step))
	 (sflagargs (unsafe_get_field :mstep_flagargs step))
	 (nodebuf (unsafe_get_field :mchgx_nodout mg))
	 (edgebuf (unsafe_get_field :mchgx_edgout mg))
	 (datamap (unsafe_get_field :mchgx_datanamemap mg))
	 (stepmap (unsafe_get_field :mchgx_stepnamemap mg))
	 (stepname (mapobject_get stepmap step))
	 (thenname (if sthen (mapobject_get stepmap sthen)))
	 (:long stephash (obj_hash step))
	 (dis (discrim step))
	 (clanam (get_field :named_name dis))
	 (flagrank (get_field :mflag_rank sflag))
	 (flagstring (get_field :mflag_string sflag))
	 (flagloc (get_field :loca_location sflag))
	 )
    (add2out_strconst nodebuf "<tr><td><font color=\"mediumseagreen\" face=\"Times-Roman Bold\" point-size=\"6\">")
    (code_chunk 
     outclanam
     #{ /* $OUTCLANAM */
     meltgc_add_out ((melt_ptr_t) $NODEBUF,
		     melt_string_str ((melt_ptr_t) $CLANAM) +6)	;
     }#)
    (add2out_strconst nodebuf "</font></td> <td>")
    (add2out_strconst nodebuf "<font face=\"Helvetica Italic\" color=\"darkgreen\" point-size=\"6.5\">")
    (add2sbuf_short_mixloc nodebuf loca)
    (add2out_strconst nodebuf "</font></td> </tr>")
    (add2out_indentnl nodebuf 0)
    (add2out_strconst nodebuf "<tr><td><font color=\"turquoise4\" face=\"Times-Roman\" point-size=\"7\">flag#")
    (add2out_longdec nodebuf (get_int flagrank))
    (if flagstring
	(progn
	  (add2out_strconst nodebuf " ")
	  (add2out_string nodebuf flagstring)
	  ))
    (add2out_strconst nodebuf "</font></td> <td><font face=\"Helvetiva Italic\" color=\"olivedrab\" point-size=\"6.5\">")
    (add2sbuf_short_mixloc nodebuf loca)
    (add2sbuf_strconst nodebuf "</font></td> </tr>")
    (if (is_multiple sflagargs)
	(progn
	  (add2out_indentnl nodebuf 0)
	  (add2out_strconst nodebuf "<tr><td colspan=\"2\"><font color=\"goldenrod4\" face=\"Times-Roman\" point-size=\"6.5\">flags{")
	  (foreach_in_multiple
	   (sflagargs)
	   (argflag :long argix)
	   (assert_msg "check argflag" (is_a argflag class_match_flag))
	   (let ( (:long argrank (get_int (get_field  :mflag_rank argflag)))
		  (argfstep (get_field :mflag_setstep argflag))
		  )
	     (if (>i argrank 0)
		 (progn
		   (add2sbuf_strconst nodebuf " ")
		   (add2sbuf_longdec nodebuf argrank)
		   ))
	     (if (is_a argfstep class_match_step_with_flag)
		 (let ( (argfstepname (mapobject_get stepmap argfstep))
			)
		   (debug "mgaltstep_stepflagoper argfstep" argfstep)
		   (debug "mgaltstep_stepflagoper argfstepname" argfstepname)
		   (if (null argfstepname) 
		       (debug "mgaltstep_stepflagoper bad stepmap" stepmap))
		   (assert_msg "check argstepname" (is_string argfstepname))
		   (add2out_indentnl edgebuf 0)
		   (add2out_string edgebuf argfstepname)
		   (add2out_strconst edgebuf " /*argflag flagop*/ -> ")
		   (add2out_string edgebuf stepname)
		   (add2out_strconst edgebuf " [ arrowhead=olnormal, color=chartreuse2, style=dotted ];")
		   ))
	     ))
	  (add2sbuf_strconst nodebuf " }</font></td> </tr>")
	  ))
    (if thenname
	(progn
	  (add2out_indentnl edgebuf 0)
	  (add2out_string edgebuf stepname)
	  (add2out_strconst edgebuf " /*then*/ -> ")
	  (add2out_string edgebuf thenname)
	  (add2out_strconst edgebuf " [ arrowhead=normal, color=green ];")
	  ))
    ))

(install_method class_match_step_flag_operation matchgraphic_altstep mgaltstep_stepflagoper)



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


(compile_warning "missing other methods for matchgraphic_altstep on other step classes")

(defun translate_matchcase (curmcase sloc prevstep)
  (debug "translate_matchcase curmcase=" curmcase "\n..prevstep=" prevstep)
  (shortbacktrace_dbg "translate_matchcase" 10)
  (assert_msg "check curmcase" (is_a curmcase class_match_case))
  (let ( (matctx (unsafe_get_field  :mcase_mctxt curmcase))
	 (curscas (unsafe_get_field :mcase_source curmcase))
	 (mloc (unsafe_get_field :loca_location curscas))
	 )
    (assert_msg "check matctx" (is_a matctx class_matching_context))
    (debug "translate_matchcase curscas" curscas)
    (debug "translate_matchcase prevstep" prevstep)
    (assert_msg "check curscas" (is_a curscas class_source_match_case))
    (let (
	  (curloc (unsafe_get_field :loca_location curscas))
	  (curpat (unsafe_get_field :scam_patt curscas))
	  (curbody (unsafe_get_field :scam_body curscas))
	  (nmatx (unsafe_get_field :mctx_nmatched matctx))
	  (mdata (unsafe_get_field :mctx_mdata matctx))
	  (ncx (unsafe_get_field :mctx_normctxt matctx))
	  (env (unsafe_get_field :mctx_env matctx))
	  (varmap (make_mapobject discr_map_objects
				  (+i 12 (*i 2 (mapobject_count (unsafe_get_field :mcase_varmap curmcase)))))) 
	  (sycmap  (unsafe_get_field :nctx_symbcachemap ncx))
	  (newenv (fresh_env env))
	  )
      (debug "translate_matchcase nmatx=" nmatx "\n.. curpat" curpat 
	     "\n.. mdata" mdata)
      (assert_msg "check ncx" (is_a ncx class_normalization_context))
      (assert_msg "check env" (is_a env class_environment))
      (multicall 
       (mstep mflag)
       (translate_pattern curpat mdata curmcase varmap sloc)
       (debug "translate_matchcase got mstep=" mstep " mflag=" mflag
	      " curbody=" curbody " varmap=" varmap)
       (foreach_in_mapobject
	(varmap)
	(cursym curmdata)
	(assert_msg "check cursym" (is_a cursym class_symbol))
	(assert_msg "check curmdata" (is_a curmdata class_matched_data))
	(let ( (matchbind (instance class_matched_binding
				    :binder cursym
				    :matchbind_data curmdata
				    :matchbind_nbocc (make_integerbox discr_integer 0)
				    ))
	       )
	  (debug "translate_matchcase matchbind=" matchbind)
	  (put_env newenv matchbind)
	  ))
       (debug "translate_matchcase updated newenv=" newenv
	      "\n before normalizing curbody=" curbody)
       (multicall
	(nbody nbinds)
	(normalize_tuple curbody newenv ncx sloc)
	(debug "translate_matchcase  after body normalization nbody=" nbody 
	       "\n nbinds=" nbinds)
	(let (
	      (listvarocc (make_list discr_list))
	      (newbindmap (get_field :env_bind newenv))
	      (stepsucc (instance class_match_step_success_when_flag
				  :loca_location sloc
				  :mstep_then ()
				  :mstep_flag mflag
				  :mstepsuccess_varocc ()
				  :mstepsuccess_binds nbinds
				  :mstepsuccess_body nbody
				  ))
	      )
	  (foreach_in_mapobject
	   (newbindmap)
	   (bsymb binding)
	   (if (and (is_a binding class_matched_binding)
		    (>i (get_int (unsafe_get_field :matchbind_nbocc binding)) 0))
	       (let ( (syocc (mapobject_get sycmap bsymb))
		      )
		 (debug "translate_matchcase found syocc=" syocc)
		 (assert_msg "check syocc" (is_a syocc class_nrep_locsymocc))
		 (assert_msg "check syocc binding" (== (get_field :nocc_bind syocc) binding))
		 (list_append listvarocc syocc)
		 )
	     ))
	  (debug "translate_matchcase listvarocc=" listvarocc "\n mstep" mstep)
	  (let ( (sortedvarocc
		  (multiple_sort 
		   (list_to_multiple listvarocc discr_multiple)
		   (lambda (o1 o2)
		     (compare_named_alpha (get_field :nocc_symb o1) (get_field :nocc_symb o2)))
		   discr_multiple))
		 )
	    (debug "translate_matchcase sortedvarocc=" sortedvarocc)
	    (put_fields 
	     stepsucc :mstepsuccess_varocc sortedvarocc))
	  (debug "translate_matchcase before putthen stepsucc=" stepsucc " mstep=" mstep)
	  (put_then_match mstep stepsucc)
	  (debug "translate_matchcase updated mstep=" mstep 
		 "\n.. prevstep=" prevstep)
	  (when prevstep
		(debug "translate_matchcase before put_else_match prevstep=" prevstep 
		       "\n.. mstep=" mstep)
		;;@@@@@THIS IS PROBABLY NEEDED@@@@
		(put_else_match prevstep mstep)
		;; beware: tmatch-5.melt is now looping
		)
	  (debug "translate_matchcase updated prevstep=" prevstep)
	  (debug "translate_matchcase return mstep=" mstep 
		 "\n stepsucc" stepsucc)
	  (return mstep stepsucc)
	  ))))))


;;;; normal representation for alternate match uses match blocks

(defclass class_nrep_matchalt
  :super class_nrep_typed_expression
  :doc #{The $CLASS_NREP_MATCHALT is the representation for normal
matches. Field $NAMATCH_MATCHED is the normal matched
stuff. $NAMATCH_RESULT gives if any the result of the
match. $NAMATCH_BODY is the body tuple, in particular labels of
$CLASS_NREP_MATCH_LABEL. $NAMATCH_FLAGS is the tuple of normal flags,
instances of $CLASS_NREP_MATCH_FLAG, and $NAMATCH_MDATAS is the tuple
of normal data, instances of $CLASS_NREP_MATCHED_DATA.}#
  :fields (
	   namatch_matched		;the normal matched stuff
	   namatch_result		;the local for the result
	   namatch_body			;the body
	   namatch_flags		;the tuple of normalized flags
	   namatch_mdatas		;the tuple of normalized match data
	   namatch_startlabel
	   ))

(defclass class_nrep_match_label
  :super class_nrep_expression
  :doc #{ A normal match label of $CLASS_NREP_MATCH_LABEL is just a
point which can be jumped to. It corresponds to a match step given by
the field $NMLAB_STEP.}#
  :fields (nmlab_step))

(defclass class_nrep_match_label_end
  :super class_nrep_match_label
  :doc #{The $CLASS_NREP_MATCH_LABEL_END is for the end label.}#)

(defclass class_nrep_match_jump
  :super class_nrep_expression
  :doc #{ A normal match jump of $CLASS_NREP_MATCH_JUMP is just a goto
to a match label given by field $NMJMP_LABEL. }#
  :fields (nmjmp_label))

(defclass class_nrep_match_data_action
  :super class_nrep_expression
  :doc #{The $CLASS_NREP_MATCH_DATA_ACTION is the common super-class
for actions concerning a normal match data $NMDAC_DATA.}# 
  :fields (nmdac_data))

(defclass class_nrep_match_data_initializer
  :super class_nrep_match_data_action
  :doc #{ A normal match data initializer of
$CLASS_NREP_MATCH_DATA_INITIALIZER initializes, allocates resource, and
clears a normal match data given by field $NMDAC_DATA.}#
  :fields ())

(defclass class_nrep_match_data_clear
  :super class_nrep_match_data_action
  :doc #{ A normal match data clear of
$CLASS_NREP_MATCH_DATA_CLEAR clears a normal match data given by
field $NMDAC_DATA.}#
  :fields ())

(defclass class_nrep_match_data_finalizer
  :super class_nrep_match_data_action
  :doc #{ A normal match data finalizer of
  $CLASS_NREP_MATCH_DATA_FINALIZER finalizes and unleashes the resources
  associated with a normal match data given by field $NMDAC_DATA.}#
  :fields ())


(defclass class_nrep_jump_when_is_a
  :super class_nrep_expression
  :doc #{The $CLASS_NREP_JUMP_WHEN_IS_A is testing if a simple value
$NTESTISA_VALUE us an instance of $NTESTISA_CLASS. If yes, it jumps to
$NTESTISA_JUMP.}#
  :fields (ntestisa_value 
	  ntestisa_class 
	  ntestisa_jump))



(defclass class_match_normalization_context
  :super class_root
  :doc #{The $CLASS_MATCH_NORMALIZATION_CONTEXT is agreggating data
  for normalization of a graph of match steps, indirect instances of
  $CLASS_MATCH_STEP. Field $MATNORX_RESLOC gives the instance of
  $CLASS_NREP_LOCSYMOCC for the result of the match. $MATNORX_NMATCH
  gives the partially built normal representation, instance of
  $CLASS_NREP_MATCHALT, of the match. Field $MATNORX_FLAGMAP is the
  read-mostly map associating match flags to normalized flags. Field
  $MATNORX_STEPMAP is the read-mostly map associating match steps to
  labels of $CLASS_NREP_MATCH_LABEL. Field $MATNORX_MDATAMAP is the
  read-mostly map associating match datas to their
  normalization. $MATNORX_MDATAQUEUE is the read-mostly queue list of
  match datas to process. $MATNORX_MSTEPQUEUE is the read-mostly queue
  list of match steps, with already an associated label, to
  process. $MATNORX_BODYLIST is the incomplete list of the match
  body. $MATNORX_ENDLABEL is the ending label. $MATNORX_MATCHCTXT
  gives the matching context of $CLASS_MATCHING_CONTEXT.}#
  :fields (matnorx_resloc
	   matnorx_nmatch
	   matnorx_datamap
	   matnorx_flagmap
	   matnorx_stepmap
	   matnorx_mdataqueue 
	   matnorx_mstepqueue 
	   matnorx_bodylist
	   matnorx_endlabel
	   matnorx_startlabel
	   matnorx_matchctxt
	   ))


;;; utility to normalize a flag with a match normalization context
(defun matchalt_normalize_flag (flag nmctxt)
  (debug "matchalt_normalize_flag flag" flag)
  (assert_msg "matchalt_normalize_flag check flag"
	      (is_a flag class_match_flag))
  (assert_msg "matchalt_normalize_flag check nmctxt"
	      (is_a nmctxt class_match_normalization_context))
  (let ( (flagmap (unsafe_get_field :matnorx_flagmap nmctxt))
	 (nfla (mapobject_get flagmap flag))
	 (nmatch (unsafe_get_field :matnorx_nmatch nmctxt))
	 )
    (if (null nfla)
	(progn 
	  (setq nfla
		(instance class_nrep_match_flag
			  :nrpfla_flag flag
			  :nrpfla_nmatch nmatch))
	  (mapobject_put flagmap flag nfla)))
    (assert_msg "matchalt_normalize_flag check nfla"
		(is_a nfla class_nrep_match_flag))
    (return nfla)
))

;;;;;;;;;;;;;;;;
(defselector normalize_step class_selector
  :doc #{The selector $NORMALIZE_STEP normalize a given $STEP within a
match normalization context $NMCTXT, a source location $SLOC, and
returns a list or tuple of normalized expressions, or a single such
normalized expression.}#
  :formals (step nmctxt sloc)
)

;; utility function to update each index of data steps in a data
(defun match_data_update_data_steps_index (mdata)
  (debug "match_data_update_steps_index mdata=" mdata)
  (assert_msg "check mdata" (is_a mdata class_matched_data))
  (let ( (msteps (get_field :mdata_steps mdata))
	 )
    (cond ( (is_list_or_null msteps)
	    (let ( (msteptup (list_to_multiple msteps))
		   )
	      (debug "match_data_update_steps_index msteptup=" msteptup)
	      (foreach_in_multiple 
	       (msteptup)
	       (curmstep :long stix)
	       (debug "match_data_update_data_steps_index curmstep=" curmstep)
	       (if (is_a curmstep class_match_step_with_data)
		   (let ( (oldixv (unsafe_get_field :mstep_index curmstep)) )
		     (if oldixv 
			 (assert_msg "check oldix" (==i (get_int oldixv) (+i stix 1)))
		       (unsafe_put_fields curmstep 
					  :mstep_index 
					  (make_integerbox discr_constant_integer (+i stix 1))))))
	       )
	      (put_fields mdata :mdata_steps msteptup)
	      (debug "match_data_update_data_steps_index updated msteptup=" 
		     msteptup "\n* updated mdata=" mdata)
	      )
	    )
	  ( (is_multiple msteps)
	    (debug "match_data_update_data_steps_index already tuple msteps=" 
		   msteps)
	    )
	  (:else
	   (debug "match_data_update_data_steps_index unexpected msteps=" msteps)
	   (assert_msg "@$@unexpected msteps in match_data_update_data_steps_index" ())))))


;; utility function to compute the index of a match step and update
;; the mdata_steps of its data to a tuple
(defun match_step_index (mstep)
  (debug "match_step_index mstep start" mstep)
  (assert_msg "check mstep" (is_a mstep class_match_step))
  (if (is_not_a mstep class_match_step_with_data)
      (progn
	(debug "match_step_index mstep without data so return nil" mstep)
	(return)))
  (let ( (matindex (unsafe_get_field :mstep_index mstep))
	 )
    (if matindex
	(progn
	  (assert_msg "check matindex" (is_integerbox matindex))
	  (return matindex))
      (let ( (matdata (get_field :mstep_data mstep))
	     )
	(debug "match_step_index matdata before match_data_update_data_steps_index" matdata)
	(match_data_update_data_steps_index matdata)
	(debug "match_step_index matdata after match_data_update_data_steps_index" matdata)
	(setq matindex  (unsafe_get_field :mstep_index mstep))
	(debug "match_step_index final matindex" matindex)
	(assert_msg "match_step_index bad matindex" (is_integerbox matindex))
	(return matindex)
	))))





;; this utility function completes a normstep if the step is the last
;; in its data, or else return the normstep unchanged...
(defun complete_normstep_if_last (step normstep nmctxt)
  (debug "complete_normstep_if_last start step=" step "\n normstep=" normstep)
  (assert_msg "check step" (is_a step class_match_step))
  (assert_msg "check nmctxt" (is_a nmctxt  class_match_normalization_context))
  (shortbacktrace_dbg "complete_normstep_if_last" 7)
  (when (is_not_a step class_match_step_with_data)
    (debug "complete_normstep_if_last returning unchanged normstep=" 
	   normstep "\n without data step=" step)
    (return normstep))
  ;;
  (let ( (matdata (get_field :mstep_data step))
	 )
    (debug "complete_normstep_if_last matdata=" matdata)
    (assert_msg "check matdata" (is_a matdata class_matched_data))
    (match_data_update_data_steps_index matdata)
    (debug "complete_normstep_if_last updated matdata=" matdata)
    (let (
	  (matindex (match_step_index step))
	  (datamap (get_field :matnorx_datamap nmctxt))
	  (ndata (mapobject_get datamap matdata))
	  )
      (debug "complete_normstep_if_last matindex=" matindex "\n ndata=" ndata
	     "\n datamap=" datamap)
      (assert_msg "check datamap" (is_mapobject datamap))
      (assert_msg "check matindex" (is_integerbox matindex))
      (assert_msg "check ndata" (is_a ndata class_nrep_simple))
      (let ( (:long numindex (get_int matindex))
	     (datasteps (get_field :mdata_steps matdata))
	     (:long nbdatasteps (multiple_length datasteps))
	     )
	(assert_msg "check numindex" (>i numindex 0))
	(assert_msg "check nbdatasteps" (>i nbdatasteps 0))
	(assert_msg "good numindex" (<=i numindex nbdatasteps))
	(if (<i numindex nbdatasteps)
	    (progn
	      (debug "complete_normstep_if_last return non-last normstep=" normstep 
		     " numindex#" numindex "\n for step=" step
		     "\n matdata=" matdata)
	      (return normstep)
	      ))
	(debug "complete_normstep_if_last last step=" step "\n ndata=" ndata)
	(if (is_a ndata class_nrep_matched_data)
	    (let ( (clearndata (instance class_nrep_match_data_clear
					 :nmdac_data ndata))
		   (finalndata (instance class_nrep_match_data_finalizer
					 :nmdac_data ndata))
		   )
	      (debug "complete_normstep_if_last with matdata=" matdata 
		     "\n made finalndata=" finalndata
		     "\n clearndata=" clearndata "\n normstep=" normstep
		     "\n for step=" step)
	      (shortbacktrace_dbg "complete_normstep_if_last made finalndata" 7)
	      (cond 
	       ( (is_a normstep class_nrep_match_jump)
		 (debug "complete_normstep_if_last matchjump normstep=" normstep)
		 ;; it has no sense to add clearing steps after a
		 ;; jump, we should do more clever things, maybe add
		 ;; them before....  perhaps remove all call to
		 ;; complete_normstep_if_last on jump steps in
		 ;; callers???
		 (assert_msg "@$@faulty complete_normstep_if_last with jumping normstep")
		 )
	       ( (is_object normstep)
		 (let ( (normsteptup (tuple normstep clearndata finalndata)) )
		   (debug "complete_normstep_if_last new normsteptup=" normsteptup)
		   (return normsteptup)))
	       ( (null normstep)
		 (let ( (steptupn (tuple clearndata finalndata)) )
		   (debug "complete_normstep_if_last new for nil steptupn=" steptupn)
		   (return steptupn)))
	       ( (is_multiple normstep)
		 (let ( (normsteplist (multiple_to_list normstep))
			(lastnormstep (multiple_nth normstep -1))
			)
		   (debug "complete_normstep_if_last tuple lastnormstep=" lastnormstep)
		   (assert_msg "check good lastnormstep" 
			       (is_not_a lastnormstep class_nrep_match_jump))
		   (list_append normsteplist clearndata)
		   (list_append normsteplist finalndata)
		   (let ( (newnormstep (list_to_multiple normsteplist)) )
		     (debug "complete_normstep_if_last tuple newnormstep=" newnormstep)
		     (return newnormstep)
		     )))
	       ( (is_list normstep)
		 (let ( (lastnormstep (list_last normstep)) )
		   (debug "complete_normstep_if_last list lastnormstep=" lastnormstep)
		   (assert_msg "check good lastnormstep" 
			       (is_not_a lastnormstep class_nrep_match_jump))
		   )
		 (list_append normstep clearndata)
		 (list_append normstep finalndata)
		 (debug "complete_normstep_if_last extended list normstep=" normstep)
		 (return normstep))
	       (:else
		(debug "complete_normstep_if_last bad normstep" normstep)
		(assert_msg "complete_normstep_if_last unexpected normstep" ())
		)))
	  (progn
	    (debug "complete_normstep_if_last not a matched data  ndata=" ndata
		   "\n unchanged normstep" normstep)
	    (return normstep))
	  )))))




;;;;;;;;;;;;;;;;
(defun normstep_anyrecv (recv nmctxt sloc)
  (debug "normstep_anyrecv recv" recv)
  (assert_msg "check nmctxt" (is_a nmctxt  class_match_normalization_context))
  (let ( (dis (discrim recv))
	 (disname (get_field :named_name dis))
	 )
    (error_strv sloc "unexpected NORMALIZE_STEP for" disname)
    (debug "normstep_anyrecv dis" dis)
    (assert_msg "@$@ unexpected normstep_anyrecv" ())
))
(install_method  discr_any_receiver normalize_step normstep_anyrecv)


(defun normstep_mflagset (step nmctxt sloc)
  (debug "normstep_mflagset step=" step "\n.. nmctxt=" nmctxt)
  (assert_msg "check step" (is_a step class_match_step_flag_set))
  (assert_msg "check nmctxt" (is_a nmctxt  class_match_normalization_context))
  (let  ( (nsloc (or (unsafe_get_field :loca_location step) sloc))
	  (matflag (unsafe_get_field :mstep_flag step))
	  (matthen (unsafe_get_field :mstep_then step))
	  (nthen (let ( (s (matchalt_normalize_step matthen nmctxt)) )
		   (debug "normstep_mflagset nthen=" s)
		   s))
	  (nflag (let ( (f (matchalt_normalize_flag matflag nmctxt)) )
		   (debug "normstep_mflagset nflag=" f)
		   f))
	  (nsetflag (let ( (n (instance  class_nrep_setq 
					 :nrep_loc nsloc
					 :nstq_var nflag
					 :nstq_exp '1)) )
		      (debug "normstep_mflagset nsetflag=" n)
		      n))
	  (ncomplsetflag (let ( (n (complete_normstep_if_last step nsetflag nmctxt)) )
			   (debug "normstep_mflagset ncomplsetflag=" n)
			   n))
	  (njump (let ( (j (instance class_nrep_match_jump
				     :nmjmp_label nthen)) )
		   (debug "normstep_mflagset njump=" j)
		   j))
	  (res (complete_sequence_as_tuple ncomplsetflag njump))
	  )
    (debug "normstep_mflagset return res=" res "\n step=" step)
    (return res)
    ))
(install_method class_match_step_flag_set normalize_step normstep_mflagset)



(defun normstep_mflagconj (step nmctxt sloc)
  (debug "normstep_mflagconj step=" step 
	 "\n.. nmctxt=" nmctxt "\n.. sloc=" sloc)
  (assert_msg "check step" (is_a step class_match_step_flag_conjunction))
  (assert_msg "check nmctxt" (is_a nmctxt  class_match_normalization_context))
  (let  ( (nsloc (or (unsafe_get_field :loca_location step) sloc))
	  (matflag (unsafe_get_field :mstep_flag step))
	  (matflagargs (unsafe_get_field :mstep_flagargs step))
	  (:long matflagnbargs (multiple_length matflagargs))
	  (matthen (unsafe_get_field :mstep_then step))
	  (nthen (let ( (s (matchalt_normalize_step matthen nmctxt)) )
		   (debug "normstep_mflagconj nthen=" s)
		   s))
	  (nflag (let ( (f (matchalt_normalize_flag matflag nmctxt)) )
		   (debug "normstep_mflagconj nflag=" f)
		   f))
	  (nsetflag (instance  class_nrep_setq 
			       :nrep_loc nsloc
			       :nstq_var nflag
			       :nstq_exp ()))
	  (njump (instance class_nrep_match_jump
			   :nmjmp_label nthen))
	  (nlisti (list nsetflag njump))
	  )
    (debug "normstep_mflagconj nlisti=" nlisti "\n matflagargs=" matflagargs)
    (cond
     ( (<=i matflagnbargs 0)
       (put_fields nsetflag :nstq_exp '0))
     ;; there are many conjunctions of flags with a single conjunct
     ;; flag argument, so we optimize it as a setq
     ( (==i matflagnbargs 1)
       (let ( (firstflag (multiple_nth matflagargs 0))
	      (n1stflag (matchalt_normalize_flag firstflag nmctxt))
	      )
       (put_fields nsetflag :nstq_exp n1stflag)))
     (:else
      (let ( (nconjlist (make_list discr_list))
	     (nchunk (instance class_nrep_chunk
					   :nrep_loc ()
					   :nchunk_oper 'and_match_flags
					   :nexpr_ctyp ctype_long
					   :nchunk_expansion ()
			       ))
	     )
	(debug "normstep_mflagconj matflagargs=" matflagargs)
	(foreach_in_multiple
	 (matflagargs)
	 (curmatflag :long flagix)
	 (debug "normstep_mflagconj curmatflag=" curmatflag " flagix=" flagix)
	 (let ( (curnflag (matchalt_normalize_flag curmatflag nmctxt))
		)
	   (debug "normstep_mflagconj curnflag=" curnflag)
	 (if (>i flagix 0)
	     (list_append nconjlist (make_stringconst discr_verbatim_string " && ")))
	 (list_append nconjlist curnflag)
	 ))
	(put_fields nchunk :nchunk_expansion (list_to_multiple nconjlist))
	(put_fields nsetflag :nstq_exp nchunk)
      )))
    (debug "normstep_mflagconj nsetflag=" nsetflag "\n step=" step)
    (let ( (res (complete_normstep_if_last step nlisti nmctxt)) )
      (debug "normstep_mflagconj return res=" res)
      (return res)
      )))
(install_method class_match_step_flag_conjunction normalize_step normstep_mflagconj)


;;;;;;;;;;;;;;;;
(defun normstep_mtestinstance (step nmctxt sloc)
  (debug "normstep_mtestinstance step=" step "\n sloc=" sloc 
	 "\n nmctxt=" nmctxt)
  (shortbacktrace_dbg "normstep_mtestinstance" 9)
  (assert_msg "check step" (is_a step class_match_step_test_instance))
  (assert_msg "check nmctxt" (is_a nmctxt  class_match_normalization_context))
  (let ( (nsloc (or (unsafe_get_field :loca_location step) sloc))
	 (matdata (unsafe_get_field :mstep_data step))
	 (matthen (unsafe_get_field :mstep_then step))
	 (matelse (unsafe_get_field :mstep_else step))
	 (matclass (unsafe_get_field :mstins_class step))
	 (matslots (unsafe_get_field :mstins_slots step))
	 (matctx (unsafe_get_field :matnorx_matchctxt nmctxt))
	 (ndata (matchalt_normalize_mdata matdata nmctxt))
	 )
    (debug "normstep_mtestinstance matclass=" matclass 
	   "\n ndata=" ndata
	   "\n matslots=" matslots 
	   "\n matthen=" matthen
	   "\n matelse=" matelse)
    (assert_msg "check matclass" (is_a matclass class_class))
    (let (
	  (nthen (let ( (s (matchalt_normalize_step matthen nmctxt)) )
		   (debug "normstep_mtestinstance nthen=" s)
		   s))
	  (jumpthen (let ( (j (instance class_nrep_match_jump
					:nmjmp_label nthen)) )
		      (debug "normstep_mtestinstance jumpthen=" j)
		      j))
	  (njthen (let ( (n (complete_normstep_if_last step jumpthen nmctxt)) )
		    (debug "normstep_mtestinstance njthen=" n)
		    n))
	  (nelse (let ( (s (matchalt_normalize_step matelse nmctxt)) )
		   (debug "normstep_mtestinstance nelse=" s)
		   s))
	  (jumpelse (let ( (j (instance class_nrep_match_jump
					:nmjmp_label nelse)) )
		      (debug "normstep_mtestinstance jumpelse=" j)
		      j))
	  (njelse (let ( (n (complete_normstep_if_last step jumpelse nmctxt)) )
		    (debug "normstep_mtestinstance njelse=" n)
		    n))
	  (ncx (get_field :mctx_normctxt matctx))
	  (env (get_field :mctx_env matctx))
	  (ncla (let ( (n (normal_exp matclass env ncx sloc)) )
		  (debug "normstep_mtestinstance ncla=" n)
		  n))
	  (clafields (unsafe_get_field :class_fields matclass))
	  (niflist (make_list discr_list))
	  (nifisa (instance class_nrep_ifisa
			    :nrep_loc sloc
			    :nif_testval ndata
			    :nifa_class ncla
			    :nexpr_ctyp ctype_void
			    :nif_then ()
			    :nif_else ()))
	  )
      (assert_msg "check nthen" (is_a nthen class_nrep_match_label))
      (assert_msg "check nelse" (is_a nelse class_nrep_match_label))
      (debug "normstep_mtestinstance njthen=" njthen " njelse=" njelse
	     "\n matslots=" matslots)
      (foreach_in_multiple
       (matslots)
       (curmslot :long curix)
       (if curmslot
	   (progn
	     (debug "normstep_mtestinstance curmslot" curmslot)
	     (assert_msg "check curmslot" (is_a curmslot class_matched_data))
	     (let ( (nslot (matchalt_normalize_mdata curmslot nmctxt))
		    (curfld (multiple_nth clafields curix))
		    (nflexp (instance class_nrep_unsafe_get_field
				      :nrep_loc nsloc
				      :nuget_obj ndata
				      :nuget_field curfld))
		    (nsetf (instance class_nrep_setq
				     :nrep_loc nsloc
				     :nstq_var nslot
				     :nstq_exp nflexp))
		    )
	       (debug "normstep_mtestinstance nslot" nslot)
	       (debug "normstep_mtestinstance curfld" curfld)
	       (debug "normstep_mtestinstance nsetf" nsetf)
	       (assert_msg "check curfld" (is_a curfld class_field))
	       (list_append niflist nsetf)
	       ))))
      (debug "normstep_mtestinstance nifisa" nifisa)
      (cond ( (is_object njthen)
	      (list_append niflist njthen))
	    ( (is_list njthen)
	      (list_append2list niflist njthen))
	    ( (is_multiple njthen)
	      (foreach_in_multiple
	       (njthen)
	       (curjthen :long jix)
	       (list_append niflist curjthen)))
	    (:else
	     (debug "normstep_mtestinstance unexpected njthen" njthen)
	     (assert_msg "normstep_mtestinstance unexpected njthen" ())))
      (debug "normstep_mtestinstance niflist" niflist)
      (let ( (nthenprogn (instance class_nrep_progn
				   :nrep_loc nsloc
				   :nprogn_seq (list_to_multiple niflist)
				   :nprogn_last ()
				   ))
	     (npelse 
	      (cond 
	       ( (is_object njelse) 
		 njelse)
	       ( (is_multiple njelse)
		 (instance class_nrep_progn
			   :nrep_loc nsloc
			   :nprogn_seq njelse
			   :nprogn_last ()))
	       (:else
		(debug "unexpected njelse=" njelse)
		(assert_msg "normstep_mtestinstance unexpected njelse" ()))))
	     )
	(unsafe_put_fields nifisa :nif_then nthenprogn :nif_else npelse)
	)
      (debug "normstep_mtestinstance updated nifisa" nifisa)
      (return nifisa)
      )))
(install_method class_match_step_test_instance normalize_step normstep_mtestinstance)


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

(defun normstep_mtestmultiple (step nmctxt sloc)
  (debug "normstep_mtestmultiple step=" step " sloc=" sloc "\n of discrim=" (discrim step))
  (assert_msg "check step" (is_a step class_match_step_test_multiple))
  (assert_msg "check nmctxt" (is_a nmctxt  class_match_normalization_context))
  (let ( (nsloc (or (unsafe_get_field :loca_location step) sloc))
	 (matdata (unsafe_get_field :mstep_data step))
	 (matthen (unsafe_get_field :mstep_then step))
	 (matelse (unsafe_get_field :mstep_else step))
	 (matindex (unsafe_get_field :mstep_index step))
	 (matctx (unsafe_get_field :matnorx_matchctxt nmctxt))
	 (:long matix (get_int matindex))
	 (matcomp (unsafe_get_field :msttup_components step))
	 (:long nbcomp (multiple_length matcomp))
	 (ndata (matchalt_normalize_mdata matdata nmctxt))
	 )
    (debug "normstep_mtestmultiple matdata=" matdata " matix=" matix 
	   "\n matcomp=" matcomp "\n ndata=" ndata)
    (let (
	  (nthen (let ( (n (matchalt_normalize_step matthen nmctxt)) )
		   (debug "normstep_mtestmultiple nthen=" n)
		   n))
	  (nelse (let ( (n (matchalt_normalize_step matelse nmctxt)) )
		   (debug "normstep_mtestmultiple nelse=" n)
		   n))
	  (jumpthen (let ( (j (instance class_nrep_match_jump
					:nmjmp_label nthen)) )
		      (debug "normstep_mtestmultiple jumpthen=" j)
		      j))
	  (njthen (let ( (n (complete_normstep_if_last step jumpthen nmctxt)) )
		    (debug "normstep_mtestmultiple njthen=" n)
		    n))
	  (jumpelse (let ( (j (instance class_nrep_match_jump
					:nmjmp_label nelse)) )
		      (debug "normstep_mtestmultiple jumpelse=" j)
		      j))
	  (njelse (let ( (n (complete_normstep_if_last step jumpelse nmctxt)) )
		    (debug "normstep_mtestmultiple njelse=" n)
		    n))
	  (ncx (get_field :mctx_normctxt matctx))
	  (niflist (make_list discr_list))
	  (nbcompval (make_integerbox discr_constant_integer nbcomp))
	  (nifistuple (instance class_nrep_iftuplesized
				:nrep_loc sloc
				:nif_testval ndata
				:nif_tupsiz nbcompval
				:nexpr_ctyp ctype_void
				:nif_then ()
				:nif_else ()
				))
	  (env (get_field :mctx_env matctx))
	  )
      (debug "normstep_mtestmultiple nthen=" nthen " nelse=" nelse)
      (assert_msg "check nthen" (is_a nthen class_nrep_match_label))
      (assert_msg "check nelse" (is_a nelse class_nrep_match_label))
      (debug "normstep_mtestmultiple njthen=" njthen " njelse=" njelse)
      (foreach_in_multiple
       (matcomp)
       (curmdata :long curix)
       (debug "normstep_mtestmultiple curmdata=" curmdata " curix=" curix)
       (if curmdata
	   (progn
	     (assert_msg "check curmdata" (is_a curmdata class_matched_data))
	     (let 
		 ( (ncompdata (matchalt_normalize_mdata curmdata nmctxt))
		   (ncompexp (instance class_nrep_unsafe_nth_component
				       :nrep_loc nsloc
				       :nunth_tuple ndata
				       :nunth_index (make_integerbox discr_constant_integer curix)
				       ))
		   (nsetf (instance class_nrep_setq
				    :nrep_loc nsloc
				    :nstq_var ncompdata
				    :nstq_exp ncompexp))
		   )
	       (debug "normstep_mtestmultiple ncompdata=" ncompdata 
		      "\n ncompexp=" ncompexp "\n nsetf=" nsetf)
	       (list_append niflist nsetf)
	       )))
       )
      (debug "normstep_mtestmultiple niflist=" niflist " nifistuple=" nifistuple)
      (cond ( (is_object njthen)
	      (list_append niflist njthen))
	    ( (is_list njthen)
	      (list_append2list niflist njthen))
	    ( (is_multiple njthen)
	      (foreach_in_multiple
	       (njthen)
	       (curjthen :long jix)
	       (list_append niflist curjthen)))
	    (:else
	     (debug "normstep_mtestmultiple unexpected njthen" njthen)
	     (assert_msg "normstep_mtestmultiple unexpected njthen" ())))
      (debug "normstep_mtestmultiple updated niflist=" niflist)
      (let ( (nthenprogn (instance class_nrep_progn
				   :nrep_loc nsloc
				   :nprogn_seq (list_to_multiple niflist)
				   :nprogn_last ()
				   ))
	     (npelse 
	      (cond 
	       ( (is_object njelse) 
		 njelse)
	       ( (is_multiple njelse)
		 (instance class_nrep_progn
			   :nrep_loc nsloc
			   :nprogn_seq njelse
			   :nprogn_last ()))
	       (:else
		(debug "unexpected njelse" njelse)
		(assert_msg "normstep_mtestmultiple unexpected njelse" ()))))
	     )
	(put_fields nifistuple :nif_then nthenprogn :nif_else npelse)
	(debug "normstep_mtestmultiple final nifistuple=" nifistuple)
	(return nifistuple)
	))))

(install_method class_match_step_test_multiple normalize_step normstep_mtestmultiple)
;;;;;;;;;;;;;;;;



(defun normstep_mtestvar (step nmctxt sloc)
  (debug "normstep_mtestvar step=" step "\n sloc=" sloc)
  (assert_msg "check step" (is_a step class_match_step_test_variable))
  (assert_msg "check nmctxt" (is_a nmctxt  class_match_normalization_context))
  (let  ( (nsloc (or (unsafe_get_field :loca_location step) sloc))
	  (matflag (unsafe_get_field :mstep_flag step))
	  (matthen (unsafe_get_field :mstep_then step))
	  (matelse (unsafe_get_field :mstep_else step))
	  (matdata (unsafe_get_field :mstep_data step))
	  (matestdata (unsafe_get_field :msteptestvar_data step))
	  (matctx (get_field :matnorx_matchctxt nmctxt))
	  )
    (debug "normstep_mtestvar matthen=" matthen
	   "\n matelse=" matelse
	   "\n matdata=" matdata
	   "\n matestdata=" matestdata)
    (let (
	  (nthen (let 
		     ( (ns (matchalt_normalize_step matthen nmctxt)) )
		   (debug "normstep_mtestvar nthen=" ns)
		   ns))
	  (nelse (let 
		     ( (ns (matchalt_normalize_step matelse nmctxt)) )
		   (debug "normstep_mtestvar nelse=" ns)
		   ns))
	  (ndata (let 
		     ( (nd (matchalt_normalize_mdata matdata nmctxt)) )
		   (debug "normstep_mtestvar ndata=" nd)
		   nd))
	  (ntestdata (let 
		     ( (nd (matchalt_normalize_mdata matestdata nmctxt)) )
		     (debug "normstep_mtestvar ntestdata=" nd)
		     nd))
	  (jumpthen (let 
			( (j (instance class_nrep_match_jump
					:nmjmp_label nthen)) )
		      (debug "normstep_mtestvar jumpthen=" j)
		      j))
	  (jumpelse (let 
			( (j (instance class_nrep_match_jump
			      :nmjmp_label nelse)) )
		      (debug "normstep_mtestvar jumpelse=" j)
		      j))
	  (ntestsame (instance class_nrep_ifsame
			       :nrep_loc nsloc
			       :nifs_left ndata
			       :nifs_right ntestdata
			       :nexpr_ctyp ctype_void
			       :nif_then ()
			       :nif_else ()))
	  )
      (debug "normstep_mtestvar nthen=" nthen "\n nelse=" nelse 
	     "\n ndata=" ndata)
      (debug "normstep_mtestvar ntestdata=" ntestdata "\n step=" step
	     "\n ntestsame=" ntestsame "\n jumpthen=" jumpthen 
	     "\n jumpelse=" jumpelse)
      ;; update ntestsame using jumpthen & jumpelse
      (put_fields ntestsame 
		  :nif_then jumpthen
		  :nif_else jumpelse)
      ;;
      (debug "normstep_mtestvar final ntestsame" ntestsame)
      (return ntestsame)
      )))
(install_method class_match_step_test_variable normalize_step normstep_mtestvar)


(defun normstep_mgroup (step nmctxt sloc)
  (debug "normstep_mgroup step=" step 
	 " class_match_step_test_group=" class_match_step_test_group 
	 " nmctxt=" nmctxt)
  (assert_msg "check step" (is_a step class_match_step_test_group))
  (assert_msg "check nmctxt" (is_a nmctxt  class_match_normalization_context))
  (let ( (matsloc (unsafe_get_field :loca_location step))
	 (matthen (unsafe_get_field :mstep_then step))
	 (matelse (unsafe_get_field :mstep_else step))
	 (matdata (unsafe_get_field :mstep_data step))
	 (matindex (unsafe_get_field :mstep_index step))
	 (mgrstart (unsafe_get_field :mstgroup_start step))
	 (mgrthen (unsafe_get_field :mstgroup_then step))
	 (mgrelse (unsafe_get_field :mstgroup_else step))
	 (ndata (matchalt_normalize_mdata matdata nmctxt))
	 (nthen (matchalt_normalize_step matthen nmctxt))
	 (nelse (matchalt_normalize_step matelse nmctxt))
	 (nstartgr (matchalt_normalize_step mgrstart nmctxt))
	 (nthengr 
	  (cond
	   ( (is_object mgrthen)
	     (matchalt_normalize_step mgrthen nmctxt))
	   ( (is_list mgrthen)
	     (list_map mgrthen (lambda (elstep) (matchalt_normalize_step elstep nmctxt)))
	     )
	   ( (is_multiple mgrthen)
	     (multiple_map mgrthen (lambda (elstep)  (matchalt_normalize_step elstep nmctxt)))
	     )
	   ( (null mgrthen)
	     ())
	   (:else
	    (debug "normstep_mgroup bad mgrthen" mgrthen)
	    (assert_msg "invalid mgrthen")
	    )))
	 (nelsegr 
	  (cond
	   ( (is_object mgrelse)
	     (matchalt_normalize_step mgrelse nmctxt))
	   ( (is_list mgrelse)
	     (list_map mgrelse (lambda (elstep) (matchalt_normalize_step elstep nmctxt)))
	     )
	   ( (is_multiple mgrelse)
	     (multiple_map mgrelse (lambda (elstep)  (matchalt_normalize_step elstep nmctxt)))
	     )
	   ( (null mgrelse)
	     ())
	   (:else
	    (debug "normstep_mgroup bad mgrelse" mgrelse)
	    (assert_msg "invalid mgrelse")
	    )))
	 )
    (debug "normstep_mgroup ndata" ndata)
    (debug "normstep_mgroup matthen" matthen)
    (debug "normstep_mgroup matelse" matelse)
    (debug "normstep_mgroup nthen" nthen)
    (debug "normstep_mgroup nelse" nelse)
    (debug "normstep_mgroup mgrstart" mgrstart)
    (debug "normstep_mgroup nstartgr" nstartgr)
    (debug "normstep_mgroup mgrthen" mgrthen)
    (debug "normstep_mgroup nthengr" nthengr)
    (debug "normstep_mgroup mgrelse" mgrelse)
    (debug "normstep_mgroup nelseg" nelsegr)
    (assert_msg "$@$unimplemented normstep_mgroup")
    ))
(install_method class_match_step_test_group normalize_step normstep_mgroup)

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

(defun normstep_msuccwhenflag (step nmctxt sloc)
  (debug "normstep_msuccwhenflag step=" step "\n.. nmctxt=" nmctxt)
  (assert_msg "check step" (is_a step class_match_step_success_when_flag))
  (assert_msg "check nmctxt" (is_a nmctxt  class_match_normalization_context))
  (let  ( (nsloc (or (unsafe_get_field :loca_location step) sloc))
	  (matflag (unsafe_get_field :mstep_flag step))
	  (matthen (unsafe_get_field :mstep_then step))
	  (matvarocc (unsafe_get_field :mstepsuccess_varocc step))
	  (nmatresloc (get_field :matnorx_resloc nmctxt))
	  (mbinds (unsafe_get_field :mstepsuccess_binds step))
	  (matbody (unsafe_get_field :mstepsuccess_body step))
	  (nendlab (get_field :matnorx_endlabel nmctxt))
	  )
    (debug "normstep_msuccwhenflag matflag=" matflag
	   " matvarocc=" matvarocc " mbinds=" mbinds "\n.. matbody=" matbody
	   " matthen=" matthen " nmatresloc=" nmatresloc
	   "\n.. nendlab=" nendlab)
    (shortbacktrace_dbg "normstep_msuccwhenflag" 14)
    (if (null mbinds) (setq mbinds (make_list discr_list)))
    (assert_msg "check mbinds" (is_list mbinds))
    (assert_msg "check nendlab" (is_a nendlab class_nrep_match_label_end))
    (foreach_in_multiple 
     (matvarocc)
     (curvarocc :long vix)
     (debug "normstep_msuccwhenflag curvarocc=" curvarocc " mbinds=" mbinds " vix=" vix)
     (assert_msg "check curvarocc" (is_a curvarocc class_nrep_locsymocc))
     (let ( (vmbind (get_field :nocc_bind curvarocc))
	    (vsym (get_field :nocc_symb curvarocc))
	    (vctyp (get_field :nocc_ctyp curvarocc))
	    (vnloc (or (get_field :nrep_loc curvarocc) nsloc))
	    (vmdata (get_field :matchbind_data vmbind))
	    )
       (debug "normstep_msuccwhenflag vix=" vix " vmbind=" vmbind " vmdata=" vmdata)
       (assert_msg "check vmbind" (is_a vmbind class_matched_binding))
       (assert_msg "check vmdata" (is_a vmdata class_matched_data))
       (let ( (nvdata (matchalt_normalize_mdata vmdata nmctxt))
	      (nvbind (instance class_normal_let_binding
				:letbind_loc vnloc
				:binder vsym
				:letbind_type vctyp 
				:letbind_expr nvdata
				))
	      )
	 (debug "normstep_msuccwhenflag vix=" vix " nvdata=" nvdata " nvbind=" nvbind)
	 (list_prepend mbinds nvbind)
	 (put_fields curvarocc :nocc_bind nvbind)
	 (debug "normstep_msuccwhenflag updated mbinds=" mbinds 
		"\n& updated curvarocc=" curvarocc	
		" vix=" vix)
	 ))) ;; end foreach_in_multiple matvarocc
    ;;
    (debug "normstep_msuccwhenflag got mbinds=" mbinds)
    (let (
	  (nthen (matchalt_normalize_step matthen nmctxt))
	  (nflag (matchalt_normalize_flag matflag nmctxt))
	  (matctx (unsafe_get_field :matnorx_matchctxt nmctxt))
	  (jumpthen (let ( (j (instance class_nrep_match_jump
					:nmjmp_label nthen)) )
		      (debug "normstep_msuccwhenflag jumpthen=" j)
		      j))
	  (jumpend (let ( (j (instance class_nrep_match_jump
					:nmjmp_label nendlab)) )
		      (debug "normstep_msuccwhenflag jumpend=" j)
		      j))
	  (:long matbodylen (multiple_length matbody))
	  (lastmatbody (multiple_nth matbody -1))
	  (nsetqres (instance class_nrep_setq
			      :nrep_loc nsloc
			      :nstq_var nmatresloc
			      :nstq_exp lastmatbody
			      ))
	  (newmatbody (make_multiple discr_multiple (+i matbodylen 2)))
	  )
      (debug "normstep_msuccwhenflag nthen=" nthen "\n nflag=" nflag)
      ;; we build a newmatbody fdrom the matbody and add the setting
      ;; of the match result and the jump
      (foreach_in_multiple
       (matbody)
       (curmatbody :long bix)
       (multiple_put_nth newmatbody bix curmatbody)
       )
      (multiple_put_nth newmatbody -2 nsetqres)
      (multiple_put_nth newmatbody -1 jumpend)
      (debug "normstep_msuccwhenflag nendlab=" nendlab "\n.. jumpend=" jumpend 
	     "\n.. nflag=" nflag "\n.. newmatbody=" newmatbody)
      (let (
	    (nifsucc (instance class_nrep_if
			       :nrep_loc nsloc
			       :nif_test nflag
			       :nif_then (wrap_normal_letseq newmatbody mbinds nsloc)
			       :nexpr_ctyp ctype_void
			       :nif_else jumpthen))
	    )
	(debug "normstep_msuccwhenflag final nifsucc=" nifsucc)
	(return nifsucc)
	))))
(install_method class_match_step_success_when_flag normalize_step normstep_msuccwhenflag)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; selector to normalize the test of matcher
;;; invoked with :
(defselector normalize_test_matcher class_selector
  :formals (recv sloc ndata bindlist nmctxt njelse)
  )

(defselector normalize_fill_matcher class_selector
  :formals (recv sloc ndata bindlist nouts nmctxt testdata)
)

(defun normtestmatch_catchall (recv sloc ndata bindlist nmctxt njelse)
  (debug "normtestmatch_catchall recv" recv)
  (debug "normtestmatch_catchall nmctxt" nmctxt)
  (debug "normtestmatch_catchall ndata" ndata)
  (debug "normtestmatch_catchall bindlist" bindlist)
  (debug "normtestmatch_catchall njelse" njelse)
  (let ( (myclass (discrim recv))
	 (myclassname (get_field :named_name myclass)) )
    (error_strv sloc 
		"unimplemented normalize_test_matcher for any " myclassname)
    (assert_msg "catchallnormalize_test_matcher  unimplemented for any receiver" ())
    ))
(install_method discr_any_receiver normalize_test_matcher normtestmatch_catchall)

(defun normfillmatch_catchall (recv sloc ndata  bindlist nouts nmctxt testextra testdata)
  (debug "normfillmatch_catchall recv" recv)
  (debug "normfillmatch_catchall nmctxt" nmctxt)
  (let ( (myclass (discrim recv))
	 (myclassname (get_field :named_name myclass)) )
    (error_strv sloc 
		"unimplemented normalize_fill_matcher for any " myclassname)
    (assert_msg "catchall normalize_test_matcher  unimplemented for any receiver" ())
    ))
(install_method discr_any_receiver normalize_fill_matcher normfillmatch_catchall)

;;;;;;;;;;;;;;;;
(defun normtestmatch_cmatcher  (recv sloc ndata bindlist nmctxt njelse)
  (debug "normtestmatch_cmatcher recv" recv)
  (assert_msg "check recv" (is_a recv class_cmatcher))
  (debug "normtestmatch_cmatcher nmctxt" nmctxt)
  (debug "normtestmatch_cmatcher ndata" ndata)
  (debug "normtestmatch_cmatcher njelse" njelse)
  (debug "normtestmatch_cmatcher bindlist" bindlist)
  (assert_msg "normtestmatch_cmatcher check nmctxt" (is_a nmctxt class_match_normalization_context))
  (let (
	(matbind (unsafe_get_field :amatch_matchbind recv))
	(matstate (unsafe_get_field :cmatch_state recv))
	(exptest (unsafe_get_field :cmatch_exptest recv))
	(:long exptestlen (multiple_length exptest))
	(:long lenbindlist (list_length bindlist))
	(matsymb (get_field :binder matbind))
	(expargs (make_multiple discr_multiple exptestlen))
	(csymstate (clone_symbol matstate))
	(csymstr (let ( (sbuf (make_strbuf discr_strbuf)) )
		    (add2sbuf_string sbuf (get_field :named_name csymstate))
		    (add2sbuf_strconst sbuf "__")
		    (add2sbuf_longdec sbuf (get_int (get_field :csym_urank csymstate)))
		    (strbuf2string discr_verbatim_string sbuf)
		    ))
	(nchunk (instance class_nrep_chunk
			      :nrep_loc sloc
			      :nchunk_expansion expargs
			      :nchunk_oper recv
			      :nexpr_ctyp ctype_long))
	(ntestelse (instance class_nrep_if
			    :nrep_loc sloc
			    :nif_test nchunk
			    :nif_then ()
			    :nif_else njelse
			    :nexpr_ctyp ctype_void))
	(bindmap (make_mapobject discr_map_objects (+i 5 (*i 2 lenbindlist))))
	)
    (debug "normtestmatch_cmatcher matbind" matbind)
    (debug "normtestmatch_cmatcher matstate" matstate)
    (debug "normtestmatch_cmatcher exptest" exptest)
    (foreach_pair_component_in_list
     (bindlist)
     (curpairbind curbind)
     (debug "normtestmatch_cmatcher curbind" curbind)
     (assert_msg "normtestmatch_cmatcher check curbind" (is_a curbind class_normal_let_binding))
     (mapobject_put bindmap (get_field :binder curbind) (get_field :letbind_expr curbind))
     )
    (assert_msg "normtestmatch_cmatcher check matbind" (is_a matbind class_any_binding))
    (foreach_in_multiple
     (exptest)
     (curexp :long ix)
     (debug "normtestmatch_cmatcher curexp" curexp)
     (cond 
      ( (is_string curexp)
	(multiple_put_nth expargs ix curexp))
      ( (== curexp matstate)
	(multiple_put_nth expargs ix csymstr))
      ( (== curexp matsymb)
	(multiple_put_nth expargs ix ndata))
      ( (is_a curexp class_symbol)
	(let ( (nval (mapobject_get bindmap curexp))
	       )
	  (debug "normtestmatch_cmatcher nval" nval)
	  (if (is_a nval class_nrep)
	      (multiple_put_nth expargs ix nval)
	    (progn
	      (error_strv sloc "unexpected symbol in cmatcher" (get_field :named_name curexp))
	      (shortbacktrace_dbg "normtestmatch_cmatcher unexpected curexp" 20)))
	  ))
      (:else
       (error_plain sloc "unexpected thing in cmatcher")
       (assert_msg "normtestmatch_cmatcher unimplemented case"))
     ))
    (debug "normtestmatch_cmatcher expargs" expargs)
    (debug "normtestmatch_cmatcher return ntestelse" ntestelse)
    (debug "normtestmatch_cmatcher return csymstate" csymstate)
    (debug "normtestmatch_cmatcher return csymstr" csymstr)
    (debug "normtestmatch_cmatcher return bindmap" bindmap)
    (return ntestelse (tuple csymstate csymstr bindmap))
    )
  )
(install_method class_cmatcher normalize_test_matcher normtestmatch_cmatcher)




(defun normfillmatch_cmatcher (recv sloc ndata bindlist nouts nmctxt testdata)
  (debug "normfillmatch_cmatcher recv" recv)
  (debug "normfillmatch_cmatcher nmctxt" nmctxt)
  (debug "normfillmatch_cmatcher ndata" ndata)
  (debug "normfillmatch_cmatcher bindlist" bindlist)
  (debug "normfillmatch_cmatcher nouts" nouts)
  (debug "normfillmatch_cmatcher testdata" testdata)
  (assert_msg "normfillmatch_cmatcher check recv" (is_a recv class_cmatcher))
  (assert_msg "normfillmatch_cmatcher check testdata" (is_multiple testdata))
  (let ( (expfill (unsafe_get_field :cmatch_expfill recv))
	 (matstate (unsafe_get_field :cmatch_state recv))
	 (matout (unsafe_get_field :amatch_out recv))
	 (matbind (unsafe_get_field :amatch_matchbind recv))
	 (matin (unsafe_get_field :amatch_in recv))
	 (:long nbexpfill (multiple_length expfill))
	 (:long nbbindlist (list_length bindlist))
	 (:long nbnouts (multiple_length nouts))
	 (nexpargs (make_multiple discr_multiple nbexpfill))
	 (cstasym (multiple_nth testdata 0))
	 (cstastr (multiple_nth testdata 1))
	 (bindmap (multiple_nth testdata 2))
	 (nfillchunk (instance class_nrep_chunk
			       :nrep_loc sloc
			       :nchunk_expansion nexpargs
			       :nchunk_oper recv
			       :nexpr_ctyp ctype_void))
	 )
    (debug "normfillmatch_cmatcher matout" matout)
    (assert_msg "normfillmatch_cmatcher check nbnouts" (==i nbnouts (multiple_length matout)))
    (foreach_in_multiple
     (nouts)
     (curnout :long noutix)
     (let ( (curoutf (multiple_nth matout noutix)) 
	    (curoutsym (get_field :binder curoutf))
	    )
       ;;(debug "normfillmatch_cmatcher curoutf" curoutf)
       ;;(debug "normfillmatch_cmatcher curoutsym" curoutsym)
       ;;(debug "normfillmatch_cmatcher curnout" curnout)
       (assert_msg "normfillmatch_cmatcher check curoutf"
		   (is_a curoutf class_formal_binding))
       (assert_msg "normfillmatch_cmatcher check curoutsym"
		   (is_a curoutsym class_symbol))
       (mapobject_put bindmap curoutsym curnout)
       ))
    (debug "normfillmatch_cmatcher updated bindmap" bindmap)
    (debug "normfillmatch_cmatcher expfill" expfill)
    (foreach_in_multiple 
     (expfill)
     (curfill :long nix)
     (debug "normfillmatch_cmatcher curfill" curfill)
     (cond 
      ( (is_string curfill)
	(multiple_put_nth nexpargs nix curfill)
	)
      ( (== curfill matstate)
	(multiple_put_nth nexpargs nix cstastr)
	)
      ( (is_a curfill class_symbol)
	(let ( (nfill (mapobject_get bindmap curfill))
	       )
	  (debug "normfillmatch_cmatcher nfill" nfill)
	  (if nfill
	      (multiple_put_nth nexpargs nix nfill)
	    (assert_msg "normfillmatch_cmatcher no nfill"))
	  ))
      (:else
       (assert_msg "unexpected curfull normfillmatch_cmatcher")))
     )
    (debug "normfillmatch_cmatcher return nfillchunk" nfillchunk)
    (return nfillchunk ())
    )
  )
(install_method class_cmatcher normalize_fill_matcher normfillmatch_cmatcher)



;;;;;;;;;;;;;;;;
(defun normstep_mtestmatcher (step nmctxt sloc)
  (debug "normstep_mtestmatcher start step=" step "\n.. nmctxt=" nmctxt "\n")
  (assert_msg "check step" (is_a step class_match_step_test_matcher))
  (assert_msg "check nmctxt" (is_a nmctxt  class_match_normalization_context))
  (let  ( (nsloc (or (unsafe_get_field :loca_location step) sloc))
	  (matthen (unsafe_get_field :mstep_then step))
	  (matelse (unsafe_get_field :mstep_else step))
	  (matdata (unsafe_get_field :mstep_data step))
	  (matindex (unsafe_get_field :mstep_index step))
	  (matmatcher (unsafe_get_field :mstma_matcher step))
	  (mins (unsafe_get_field :mstma_ins step))
	  (mouts (unsafe_get_field :mstma_outs step))
	  (matctx (unsafe_get_field :matnorx_matchctxt nmctxt))
	  )
    (debug "normstep_mtestmatcher matdata=" matdata
	   "\n.. mins=" mins
	   "\n.. mouts=" mouts
	   "\n.. matmatcher=" matmatcher)
    (assert_msg "check matmatcher" (is_a matmatcher class_any_matcher))
    (let ( 
	  (nthen (matchalt_normalize_step matthen nmctxt))
	  (nelse (matchalt_normalize_step matelse nmctxt))
	  (ndata (matchalt_normalize_mdata matdata nmctxt))
	  (jumpthen (let ( (j (instance class_nrep_match_jump
					:nmjmp_label nthen)) )
		      (debug "normstep_mtestmatcher jumpthen=" j)
		      j))
	  (jumpelse (let ( (j (instance class_nrep_match_jump
					:nmjmp_label nelse)) )
		      (debug "normstep_mtestmatcher jumpelse=" j)
		      j))
	  (amin (get_field :amatch_in matmatcher))
	  (ambind (get_field :amatch_matchbind matmatcher))
	  (amout (get_field :amatch_out matmatcher))
	  (env (get_field :mctx_env matctx))
	  (newenv (fresh_env env))
	  (newbindlist (make_list discr_list))
	  (:long nbmouts (multiple_length mouts))
	  (normouts (make_multiple discr_multiple nbmouts))
	  )
      (debug "normstep_mtestmatcher ndata=" ndata 
	     "\n.. ambind=" ambind 
	     "\n.. amin=" amin
	     "\n.. mins=" mins
	     "\n.. matctx=" matctx)
      (assert_msg "check env" (is_a env class_environment))
      ;; bind the matched data
      (assert_msg "check ambind" (is_a ambind class_formal_binding))
      (let ( (ambinder (get_field :binder ambind))
	     (amctype (get_field :fbind_type ambind))
	     (datctype (get_ctype ndata env)) 
	     (newambinding (instance class_normal_let_binding
				     :letbind_loc nsloc
				     :binder ambinder
				     :letbind_type amctype
				     :letbind_expr ndata))
	     )
	(debug "normstep_mtestmatcher newambinding=" newambinding)
	(if (!= amctype datctype)
	    (progn
	      (error_strv nsloc "invalid matched data ctype in matcher"
			  (get_field :named_name matmatcher))
	      (warning_strv nsloc "expected matched data ctype" 
			    (get_field :named_name amctype))
	      (warning_strv nsloc "actual matched data ctype"
			    (get_field :named_name datctype))
	      )
	  (put_env newenv newambinding)
	  )
	(debug "normstep_mtestmatcher newambinding" newambinding)
	(list_append newbindlist newambinding)
	;; bind the matched inputs
	(if (!=i (multiple_length amin) (multiple_length mins))
	    (error_strv nsloc
			"mismatch on input arity of matcher"
			(get_field :named_name matmatcher))
	  )
	(foreach_in_multiple
	 (amin)
	 (curmin :long minix)
	 (let ( (curins (multiple_nth mins minix))
		(curctype (get_ctype curins env))
		(curmintype (get_field :fbind_type curmin))
		(curminbinder (get_field :binder curmin))
		)
	   (debug "normstep_mtestmatcher curmin" curmin)
	   (debug "normstep_mtestmatcher curins" curins)
	   (debug "normstep_mtestmatcher curctype" curctype)
	   (assert_msg "check curmin" (is_a curmin class_formal_binding))
	   (if (!= curmintype curctype)
	       (progn
		 (error_strv nsloc "mismatched input data in matcher"
			     (get_field :named_name matmatcher))
		 (warning_strv nsloc "invalid ctype in matcher pattern input"
			       (get_field :named_name curminbinder))
		 (warning_strv nsloc "got ctype"
			       (get_field :named_name curctype))
		 (warning_strv nsloc "expecting ctype"
			       (get_field :named_name curmintype))
		 ))
	   (let ( (newbinding (instance class_normal_let_binding
					:letbind_loc nsloc
					:binder curminbinder
					:letbind_type curctype
					:letbind_expr curins)
			      ) )
	     (debug "normstep_mtestmatcher newbinding=" newbinding)
	     (put_env newenv newbinding)
	     (list_append newbindlist newbinding)
	     )
	   ))
	(debug "normstep_mtestmatcher newbindlist" newbindlist
	       "\n.. amout" amout "\n.. mouts again" mouts)
	(if (!=i (multiple_length amout) (multiple_length mouts))
	    (error_strv nsloc 
			"mismatch on output arity of matcher" 
			(get_field :named_name matmatcher)))
	(foreach_in_multiple
	 (amout)
	 (curmoutbind :long mix)
	 (let ( (curouts (multiple_nth mouts mix))
		)
	   (debug "normstep_mtestmatcher curmoutbind=" curmoutbind
		  "\n.. curouts=" curouts)
	   (assert_msg "check curmoutbind" (is_a curmoutbind class_formal_binding))
	   (assert_msg "check curouts" (is_a curouts class_matched_data))
	   (let (  (nouts (matchalt_normalize_mdata curouts nmctxt))
		   )
	     (debug "normstep_mtestmatcher nouts" nouts)
	     ;; nouts is a class_nrep_matched_data
	     (assert_msg "check nouts" (is_a nouts class_nrep_matched_data))
	     (multiple_put_nth normouts mix nouts)
	     )
	   ))
	;;
	(debug "normstep_mtestmatcher normouts=" normouts)
	;; we should probably have a selector to make the test part of a matching
	;; and another selector to make the fill part of it
	(debug "normstep_mtestmatcher before normalize_test_matcher matmatcher=" matmatcher
	       "\n... ndata=" ndata "\n..jumpelse=" jumpelse)
	(multicall
	 (ntest testdata)
	 (normalize_test_matcher matmatcher sloc ndata newbindlist nmctxt jumpelse)
	 (debug "normstep_mtestmatcher after normalize_test_matcher ntest=" ntest 
		"\n.. testdata=" testdata)
	 (let ( 
	       (nfill
		(normalize_fill_matcher matmatcher 
					sloc ndata newbindlist normouts nmctxt testdata))
	       )
	   (debug "normstep_mtestmatcher after normalize_fill_matcher nfill=" nfill)
	   (let ( (restup (tuple ntest nfill jumpthen)) )
	     (debug "normstep_mtestmatcher return restup=" restup)
	     (return restup)
	     )))))))
(install_method class_match_step_test_matcher normalize_step normstep_mtestmatcher)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; utility to normalize a step with a match normalization context
(defun matchalt_normalize_step (step nmctxt)
  (debug "matchalt_normalize_step step" step)
  (assert_msg "matchalt_normalize_step check nmctxt" (is_a nmctxt class_match_normalization_context))
  (shortbacktrace_dbg "matchalt_normalize_step" 14)
  ;; special case, null step so gives the end label
  (if (null step)
      (let ( (endlab (unsafe_get_field :matnorx_endlabel nmctxt))
	     )
	(debug "matchalt_normalize_step null step so return endlab" endlab)
	(return endlab)))
  (assert_msg "matchalt_normalize_step check step" (is_a step class_match_step))
  (let ( (stepmap (unsafe_get_field :matnorx_stepmap nmctxt))
	 (nlab (mapobject_get stepmap step))
	 (bodyl (unsafe_get_field :matnorx_bodylist nmctxt))
	 (sloc  (get_field :loca_location step))
	 (mstepqueue (unsafe_get_field :matnorx_mstepqueue nmctxt))
	 )
    (if (null nlab)
	(let ( (newlab 
		(instance class_nrep_match_label
			  :nrep_loc sloc
			  :nmlab_step step))
	       )
	  (debug "matchalt_normalize_step newlab" newlab)
	  (mapobject_put stepmap step newlab)
	  (list_append mstepqueue step)
	  (debug "matchalt_normalize_step updated mstepqueue" mstepqueue)
	  (setq nlab newlab)
	  ))
    (assert_msg "check good nlab" (is_a nlab class_nrep_match_label))
    (return nlab)
    ))


;;;;;;;;;;;;;;;;
;;; utility to normalize a matched data with a match normalization context
(defun matchalt_normalize_mdata (mdata nmctxt)
  (debug "matchalt_normalize_mdata mdata=" mdata "\n* of discrim:" (discrim mdata) "\n")
  (shortbacktrace_dbg "matchalt_normalize_mdata" 7)
  (assert_msg "matchalt_normalize_mdata check mdata" (is_a mdata class_matched_data))
  (assert_msg "matchalt_normalize_mdata check nmctxt" (is_a nmctxt class_match_normalization_context))
  (let ( (datamap (unsafe_get_field :matnorx_datamap nmctxt))
	 (ndata (mapobject_get datamap mdata))
	 (mdataqueue (unsafe_get_field :matnorx_mdataqueue  nmctxt))
	 (bodyl (unsafe_get_field :matnorx_bodylist nmctxt))
	 )
    (if ndata
	(progn
	  (debug "matchalt_normalize_mdata found cached ndata=" ndata)
	  (return ndata)))
    ;;
    ;; test if mdata is the original data to be matched - ie the first
    ;; argument to our (match ...)
    (if (is_a mdata class_matched_normal_data)
	(progn 
	  (setq ndata (unsafe_get_field :mdata_orig mdata))
	  (list_append mdataqueue mdata)
	  (mapobject_put datamap mdata ndata)
	  (debug "matchalt_normalize_mdata return normal ndata=" ndata 
		 "\n of disrim=" (discrim ndata)
		 "\n from mdata=" mdata
		 "\n updated mdataqueue=" mdataqueue
		 "\n updated datamap=" datamap)
	  (return ndata)
	  )
      (let ( (msymb (get_field :mdata_symb mdata))
	     (mctyp (get_field :mdata_ctype mdata))
	     (sloc (get_field :loca_location 
			      (get_field :mdata_orig mdata)))
	     (:long datacount (mapobject_count datamap))
	     (newdata (instance class_nrep_matched_data
				:nrep_loc sloc
				:nrmatd_ctype mctyp
				:nrmatd_mdata mdata
				:nrmatd_rank (make_integerbox discr_constant_integer
							      datacount)
				))
	     (newdatainit (instance class_nrep_match_data_initializer
				    :nrep_loc ()
				    :nmdac_data newdata))
	     )
	(debug "matchalt_normalize_mdata make newdata=" newdata 
	       "\n* for mdata=" mdata
	       "\n* of discrim:" (discrim mdata))
	(setq ndata newdata)
	(list_append bodyl newdatainit)
	(mapobject_put datamap mdata ndata)
	(list_append mdataqueue mdata)
	(debug "matchalt_normalize_mdata final ndata=" ndata 
	       "\n* for mdata=" mdata
	       "\n* updated datamap=" datamap 
	       "\n* updated mdataqueue=" mdataqueue)
	(return ndata)
	))))


(defun matchalt_handle_normalized_mdata (matdata ndata nmctxt)
  (debug "matchalt_handle_normalized_mdata matdata" matdata 
	 "\n* ndata" ndata)
  (assert_msg "check matdata" (is_a matdata class_matched_data))
  (assert_msg "check ndata" (is_a ndata class_nrep_simple))
  (let ( (msteps (unsafe_get_field :mdata_steps matdata))
	 )
    (debug "matchalt_handle_normalized_mdata msteps=" msteps)
    (cond
     ((is_multiple msteps)
      (void))
     ((is_non_empty_list msteps)
      (debug "matchalt_handle_normalized_mdata nonemptylist msteps=" msteps)
      (debug "matchalt_handle_normalized_mdata matdata before match_data_update_data_steps_index" matdata)
      (match_data_update_data_steps_index matdata)
      (debug "matchalt_handle_normalized_mdata matdata after match_data_update_data_steps_index" matdata)
      (setq msteps (unsafe_get_field :mdata_steps matdata))
      (debug "matchalt_handle_normalized_mdata msteps after match_data_update_data_steps" msteps)
      )
     (:else
      (setq msteps (make_multiple discr_multiple 0))
      (debug "matchalt_handle_normalized_mdata msteps emptytuple" msteps)))
    (debug "matchalt_handle_normalized_mdata updated msteps" msteps)
    (assert_msg "good tuple msteps" (is_multiple msteps))
    (foreach_in_multiple
     (msteps)
     (curstep :long stepix)
     (debug "matchalt_handle_normalized_mdata befora normalizing curstep" curstep)
     (let ( (nlab (matchalt_normalize_step curstep nmctxt))
	    )
       (debug "matchalt_handle_normalized_mdata after normalizing nlab" nlab)
       ))
    (debug "matchalt_normalize_step final nmctxt" nmctxt)
    ))


;;; utility function to make a match normalization context
(defun matchalt_make_match_normalization_context (matctx matctyp sloc)
  (debug "matchalt_make_match_normalization_context matctx" matctx)
  (debug "matchalt_make_match_normalization_context matctyp" matctyp)
  (let 
      ( (nmatch (instance class_nrep_matchalt
			  :nexpr_ctyp matctyp
			  :nrep_loc sloc
			  :namatch_matched ()
			  :namatch_result ()
			  :namatch_flags ()
			  ))
	;; maybe we should handle particularily the case when matctyp
	;; is :void
	(mrsymb  (clone_symbol '_matchres))
	(mrbind (instance class_normal_let_binding
			  :letbind_loc sloc
			  :binder mrsymb
			  :letbind_type matctyp 
			  :letbind_expr ()))
	(mcalocc  (instance class_nrep_locsymocc
			    :nrep_loc sloc
			    :nocc_ctyp matctyp
			    :nocc_symb mrsymb
			    :nocc_bind mrbind
			    ))
	;; associate match flags to normal flags
	(flagmap (make_mapobject discr_map_objects 83)) 
	;; associate steps to match blocks, which can be possibly
	;; empty 
	(stepmap (make_mapobject discr_map_objects 229))
	;; associate match data to their normalization
	(datamap (make_mapobject discr_map_objects 229))
	;; the queue of matched data to process
	(mdataqueue (make_list discr_list))
	;; the queue of match steps to process
	(mstepqueue (make_list discr_list))
	;; the body queue
	(bodyl (make_list discr_list))
	;; the end label
	(endlab (instance  class_nrep_match_label_end
			   :nrep_loc sloc
			   :nmlab_step ()
		 ))
	;; the normal matching context
	(nmctxt (instance  class_match_normalization_context
			   :matnorx_resloc mcalocc
			   :matnorx_nmatch nmatch
			   :matnorx_datamap datamap
			   :matnorx_flagmap flagmap
			   :matnorx_stepmap stepmap
			   :matnorx_mdataqueue mdataqueue
			   :matnorx_mstepqueue mstepqueue
			   :matnorx_bodylist bodyl
			   :matnorx_endlabel endlab
			   :matnorx_matchctxt matctx
			   ))
	)
    (debug "matchalt_make_match_normalization_context result nmctxt=" nmctxt
	   "\n* mrbind=" mrbind)
    (return nmctxt)
    ))

;;; function to really normalize an alternate match context
;;; called from normexp_matchalt
(defun matchalt_normalize_match_context (mdata sloc nmctxt)
  (debug "matchalt_normalize_match_context mdata=" mdata
	 "\n sloc=" sloc "\n nmctxt=" nmctxt)
  (shortbacktrace_dbg "matchalt_normalize_match_context" 15)
  (assert_msg "check nmctxt" (is_a nmctxt class_match_normalization_context))
  (let ( (mdataqueue (unsafe_get_field :matnorx_mdataqueue nmctxt))
	 (mstepqueue (unsafe_get_field :matnorx_mstepqueue nmctxt))
	 (datamap (unsafe_get_field :matnorx_datamap nmctxt))
	 (stepmap (unsafe_get_field :matnorx_stepmap nmctxt))
	 (bodyl (unsafe_get_field :matnorx_bodylist nmctxt))
	 (firststeplab ())
	 )
    (debug "matchalt_normalize_match_context starting with first mdata" mdata)
    (matchalt_normalize_mdata mdata nmctxt)
    (debug "matchalt_normalize_match_context initial mdataqueue" mdataqueue)
    (debug "matchalt_normalize_match_context initial datamap" datamap)
    (forever 
     matchdatanormalizeloop
     (let ( (freshmdata (list_popfirst mdataqueue)) 
	    (ndata (mapobject_get datamap freshmdata))
	    )
       (debug "matchalt_normalize_match_context freshmdata start loop" freshmdata)
       (debug "matchalt_normalize_match_context ndata start loop" ndata)
       (if (null freshmdata) (exit matchdatanormalizeloop))
       (assert_msg "matchalt_normalize_match_context check freshmdata" 
		   (is_a freshmdata class_matched_data))
       (assert_msg "matchalt_normalize_match_context check ndata"
		   (is_a ndata class_nrep_simple))
       (matchalt_handle_normalized_mdata freshmdata ndata nmctxt)
       (debug "matchalt_normalize_match_context after matchalt_handle_normalized_mdata freshmdata=" freshmdata 
	      "\n mstepqueue=" mstepqueue)
       (forever
	matchstepnormalizeloop
	(debug "matchalt_handle_normalized_mdata +matchstepnormalizeloop mstepqueue=" mstepqueue)
	(let ( (freshmstep (list_popfirst mstepqueue)) 
	       (freshlab (mapobject_get stepmap freshmstep))
	       )
	  (debug "matchalt_normalize_match_context freshmstep=" freshmstep "\n freshlab=" freshlab)
	  (if (null freshmstep) (exit matchstepnormalizeloop))
	  (debug "matchalt_normalize_match_context before normalize_step bodyl=" bodyl
		 "\n freshmstep=" freshmstep)
	  (when (null firststeplab) 
	    (setq firststeplab freshlab)
	    (debug "matchalt_normalize_match_context set firststeplab=" firststeplab))
	  (let ( 
		(normstep (normalize_step freshmstep nmctxt sloc)) 
		)
	    (list_append bodyl freshlab)
	    (debug "matchalt_normalize_match_context after normalize_step freshmstep=" freshmstep
		   "\n normstep=" normstep "\n bodyl=" bodyl)
	    (letrec ( (add_norm_step
		       (lambda (ns)
			 (cond 
			  ( (is_a ns class_nrep_expression)
			    (list_append bodyl ns))
			  ( (is_list ns)
			    (foreach_pair_component_in_list
			     (ns)
			     (curpair curcomp)
			     (add_norm_step curcomp)))
			  ( (is_multiple ns)
			    (foreach_in_multiple
			     (ns)
			     (curcomp :long ix)
			     (add_norm_step curcomp)))
			  (:else
			   (debug "add_norm_step bad ns" ns)
			   (assert_msg "add_norm_step invalid argument")
			   ))))
		      )
	      (add_norm_step normstep))
	    )
	  )
	)			  ; end forever matchstepnormalizeloop
       )
     )				   ;end forever matchdatanormalizeloop
    ;;
    (put_fields nmctxt :matnorx_startlabel firststeplab)
    (debug "matchalt_normalize_match_context ending firststeplab=" firststeplab "\n bodyl=" bodyl 
	   "\n nmctxt=" nmctxt)
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; normalize a match alternate
(defun normexp_matchalt (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 "normexp_matchalt recv=" recv)
  (shortbacktrace_dbg "normexp_matchalt start" 20)
  (let ( (sloc (or (unsafe_get_field :loca_location recv) psloc))
	 (smatsx (unsafe_get_field :smat_matchedx recv))
	 (scases (unsafe_get_field :smat_cases recv))
	 (:long nbcases (multiple_length scases))
	 (firststep ())
	 (cintsymb (clone_symbol 'matchalt_inter_))
	 (nchint (instance class_nrep_checksignal
			   :nrep_loc sloc))
	 (cintbind (instance class_normal_let_binding
			     :binder cintsymb
			     :letbind_type ctype_void
			     :letbind_expr nchint))
	 )
    (debug "normexp_matchalt scases=" scases " smatsx=" smatsx)
    (multicall
     (nmatx nbindmatx)
     (normal_exp smatsx env ncx sloc)
     (debug "normexp_matchalt nmatx=" nmatx " nbindmatx=" nbindmatx)
     (if (is_list nbindmatx)
	 (list_append nbindmatx cintbind)
       (setq nbindmatx (list cintbind)))
     (debug "normexp_matchalt updated nbindmatx=" nbindmatx)
     (let ( (matctyp (get_ctype nmatx env))
	    (mcasetup (make_multiple discr_multiple nbcases))
	    (msteplist (make_list discr_list))
	    (msymb (or (get_field :nocc_symb nmatx) 
		       (clone_symbol (or (get_field :named_name nmatx)
					 '_matched_data))))
	    (mdata (instance class_matched_normal_data
			     :mdata_symb msymb
			     :mdata_ctype matctyp
			     :mdata_orig nmatx
			     :mdata_steps msteplist
			     ))
	    ;; the end label
	    (endlab (instance class_nrep_match_label_end
			      :nrep_loc sloc
			      :nmlab_step ())
		    )
	    (matctx (instance class_matching_context
			      :mctx_normctxt ncx
			      :mctx_source recv
			      :mctx_nmatched nmatx
			      :mctx_nmatbind nbindmatx
			      :mctx_cases mcasetup
			      :mctx_env env
			      :mctx_mdata mdata
			      :mctx_varhandlers (make_list discr_list)
			      :mctx_flags (make_list discr_list)
			      :mctx_endlabel endlab
			      ))
	    )
       (debug "normexp_matchalt matctyp=" matctyp
	      "\n mdata=" mdata "\n matctx=" matctx "\n scases=" scases)
       ;; build each match case
       (foreach_in_multiple
	(scases)
	(curscas :long curix)
	(debug "normexp_matchalt curscas=" curscas " curix=" curix)
	(assert_msg "check  curscas" (is_a curscas class_source_match_case))
	(let ( (curmcase (instance class_match_case
				   :mcase_mctxt matctx
				   :mcase_source curscas
				   :mcase_index 
				   (make_integerbox discr_constant_integer curix)
				   )
			 )
	       )
	  (debug "normexp_matchalt empty curmcase=" curmcase)
	  (fill_matchcase curmcase sloc)
	  (debug "normexp_matchalt filled curmcase=" curmcase)
	  (multiple_put_nth mcasetup curix curmcase)
	  ))
       (debug "normexp_matchalt mcasetup=" mcasetup)
       ;; translate each match case
       (let ( (prevstep ()) 
	      (matresctyp ())
	      )
	 (foreach_in_multiple
	  (mcasetup)
	  (curmcase :long mix)
	  (debug "normexp_matchalt before translate_matchcase curmcase=" curmcase
		 "\n.. prevstep=" prevstep)
	  (let ( (mcasloc (or (get_field :loca_location (get_field :mcase_source curmcase)) sloc))
		 )
	    (multicall
	     (curstep curstsucc)
	     (translate_matchcase curmcase mcasloc prevstep)
	     (debug "normexp_matchalt after translate_matchcase curstep=" curstep 
		    "\n.. curstsucc=" curstsucc)
	     (assert_msg "check curstsucc" (is_a curstsucc class_match_step_success_when_flag))
	     (let ( 
		   (curstbindtup (unsafe_get_field :mstepsuccess_binds curstsucc))
		   (lastnbody
		    (let ( (l
			    (multiple_nth
			     (unsafe_get_field :mstepsuccess_body curstsucc) 
			     -1))
			   )
		      (debug "normexp_matchalt lastnbody" l)
		      l))
		   (lastctyp
		    (if (is_a lastnbody class_nrep_locsymocc)
			(unsafe_get_field :nocc_ctyp lastnbody)
		      (let ( (newcurenv (fresh_env env))
			     )
			(foreach_in_multiple
			 (curstbindtup)
			 (curstepbind :long bix)
			 (put_env newcurenv curstepbind)
			 )
			(get_ctype lastnbody newcurenv)
			)))
		   )
	       (debug "normexp_matchalt lastnbody=" lastnbody
		      "\n.. lastctyp=" lastctyp)
	       (assert_msg "check lastctyp" (is_a lastctyp class_ctype))
	       (cond ( (null matresctyp)
		       (setq matresctyp lastctyp))
		     ( (== matresctyp lastctyp)
		       (void))
		     ( (== matresctyp ctype_void)
		       (void))
		     ( (== lastctyp ctype_void)
		       (setq matresctyp ctype_void))
		     (:else
		      (warning_plain mcasloc "MATCH cases with incompatible types so using :VOID")
		      (setq matresctyp ctype_void)))
	       (if curstep (setq prevstep curstep))
	       (if (null firststep)
		   (setq firststep curstep))
	       ))
	    (debug "normexp_matchalt updated prevstep" prevstep)
	    ))			     ;end foreach_in_multiple mcasetup
	 ;;
	 (debug "normexp_matchalt firststep=" firststep 
		"\n.. matresctyp=" matresctyp
		"\n..updated mdata=" mdata)
	 (if (melt_need_dbg 1)
	     (let ( (dotprefix (get_field :referenced_value match_graphic_dot_prefix)) )
	       (debug "normexp_matchalt dotprefix=" dotprefix
		      " match_graphic_dot_prefix=" match_graphic_dot_prefix)
	       (if (is_string dotprefix) 
		   (mg_altdraw_graphviz mdata dotprefix))))
	 (let ( (nmctxt (matchalt_make_match_normalization_context matctx matresctyp sloc))
		)
	   (debug "normexp_matchalt before matchalt_normalize_match_context nmctxt=" nmctxt)
	   ;;
	   (matchalt_normalize_match_context mdata sloc nmctxt)
	   (debug "normexp_matchalt after matchalt_normalize_match_context nmctxt=" nmctxt)
	   (let ( 
		 (nresloc (unsafe_get_field :matnorx_resloc nmctxt))
		 (nresmatch (unsafe_get_field :matnorx_nmatch nmctxt))
		 (nbodyl (unsafe_get_field :matnorx_bodylist nmctxt))
		 (nflagmap (unsafe_get_field :matnorx_flagmap nmctxt))
		 (ndatamap (unsafe_get_field :matnorx_datamap nmctxt))
		 (nstartlab (unsafe_get_field :matnorx_startlabel nmctxt))
		 (nendlab (unsafe_get_field :matnorx_endlabel nmctxt))
		 (nresbind (get_field :nocc_bind nresloc))
		 (nflagslist (make_list discr_list))
		 (ndatalist (make_list discr_list))
		 )
	     (debug "normexp_matchalt nresloc=" nresloc 
		    "\n* nbodyl=" nbodyl
		    "\n* nflagmap=" nflagmap
		    "\n* nstartlab=" nstartlab)
	     (foreach_in_mapobject
	      (nflagmap)
	      (curflag curnormflag)
	      (list_append nflagslist curnormflag))
	     (debug "normexp_matchalt nflagslist" nflagslist)
	     ;; sort the nflagslist using the mflag_rank of nrpfla_flag
	     (let ( (rawnflagstup (list_to_multiple nflagslist))
		    (sortedflagstup
		     (multiple_sort
		      rawnflagstup
		      (lambda (nf1 nf2)
			(assert_msg "check nf1" (is_a nf1 class_nrep_match_flag))
			(assert_msg "check nf2" (is_a nf2 class_nrep_match_flag))
			(return :true (-i 
				       (get_int (get_field :mflag_rank (get_field :nrpfla_flag nf1)))
				       (get_int (get_field :mflag_rank (get_field :nrpfla_flag nf2)))
				       )))
		      discr_multiple
		      ))
		    )
	       (assert_msg "check nresmatch" (is_a nresmatch class_nrep_matchalt))
;;;
	       (debug "normexp_matchalt ndatamap=" ndatamap)
	       (foreach_in_mapobject
		(ndatamap)
		(curndata curnorm)
		(debug "normexp_matchalt curndata=" curndata 
		       "\n** of discrim:" (discrim curndata)
		       "\n* curnorm=" curnorm
		       "\n** of discrim:" (discrim curnorm)
		       "\n")
		(if (is_a curnorm class_nrep_matched_data)
		    (let (
			  )
		      (debug "normexp_matchalt good curnorm=" curnorm)
		      (list_append ndatalist curnorm)
		      ))
		)
	       (debug "normexp_matchalt ndatalist=" ndatalist)
	       ;;
	       (let ( (:long nbndata (list_length ndatalist))
		      (ndatatup (make_multiple discr_multiple nbndata))
		      )
		 (foreach_pair_component_in_list
		  (ndatalist)
		  (curpaird curndata)
		  (debug "normexp_matchalt curndata=" curndata)
		  (assert_msg "check curndata" (is_a curndata class_nrep_matched_data))
		  (let ( (:long curnrk (get_int (get_field  :nrmatd_rank curndata)))
			 (:long curnrkm1 (-i curnrk 1))
			 )
		    (assert_msg "check curnrk" (>i curnrk 0))
		    (assert_msg "emprty datatup slot" 
				(null (multiple_nth ndatatup curnrkm1)))
		    (multiple_put_nth ndatatup curnrkm1 curndata)
		    )
		  )
		 (list_append nbodyl endlab)
		 (debug "normexp_matchalt ndatatup=" ndatatup "\n *nbodyl=" nbodyl)
		 ;;
		 (put_fields nresmatch
			     :namatch_matched nmatx ;; normal matched stuff
			     :namatch_result nresloc
			     :namatch_body (list_to_multiple nbodyl)
			     :namatch_flags sortedflagstup
			     :namatch_mdatas ndatatup
			     :namatch_startlabel nstartlab
			     )
		 (let (
		       (csym (clone_symbol 'matchaltres_))
		       (cbind (instance class_normal_let_binding
					:letbind_loc sloc
					:binder csym
					:letbind_type matresctyp
					:letbind_expr nresmatch))
		       (clocc (instance  class_nrep_locsymocc
					  :nrep_loc sloc
					  :nocc_ctyp matresctyp
					  :nocc_symb csym
					  :nocc_bind cbind
					  ))  
		       )
		 (debug "normexp_matchalt nresmatch=" nresmatch
			"\n* of discrim:" (discrim nresmatch)
			"\n* matresctyp=" matresctyp
			)
		 (debug "normexp_matchalt final nresbind=" nresbind
			"\n cbind=" cbind
			"\n clocc=" clocc
			"\n nresloc=" nresloc)
		 (return clocc (list nresbind cbind))
		 ))))))))))
(install_method class_source_matchalt normal_exp normexp_matchalt)

;;;;;;;;;;;;;;;;
(defun alternate_match_optset (optsymb :cstring opts)
  (debug "alternate_match_optset optsymb" optsymb)
  (informsg_plain "exchange alternate matching implementation")
  (install_method class_source_match normal_exp normexp_matchalt)
  (install_method class_source_matchalt normal_exp normexp_matchalt)
)





;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; display the graphic of matchalt normalization for Graphviz in .dot
;; format notice that the numbering of steps is local to this
;; function...
(defun mg_altdraw_graphviz (mdata dotprefix)
  (let ( (mapdata (make_mapobject discr_map_objects 43))
	 (mapstep (make_mapobject discr_map_objects 43))
	 (nodebuf (make_strbuf discr_strbuf))
	 (edgebuf (make_strbuf discr_strbuf))
	 (datacountbox (make_integerbox discr_integer 0))
	 (:long cnt 0) 
	 (:long mdatahash (obj_hash mdata))
	 (pathsbuf (make_strbuf discr_strbuf)) 
	 (dotfilename
	  (progn
	    (code_chunk 
	     uniqcnt 
	     #{  /* mg_draw_match_graphviz_file $UNIQCNT */
	     static long uniqcounter	;
	     uniqcounter ++		;
	     $CNT = uniqcounter		; 
	     }#)
	    (assert_msg "check pathsbuf" (is_strbuf pathsbuf))
	    (add2sbuf_string pathsbuf dotprefix)
	    (add2sbuf_strconst pathsbuf "+")
	    (add2sbuf_longdec pathsbuf cnt)
	    (add2sbuf_strconst pathsbuf ".dot")
	    (debug "mg_draw_match_graphviz_file pathsbuf" pathsbuf)
	    (strbuf2string discr_string pathsbuf)))
	 (mg (instance class_match_graphic
		       :mchgx_filename dotfilename
		       :mchgx_nodout nodebuf
		       :mchgx_edgout edgebuf
		       :mchgx_datanamemap mapdata
		       :mchgx_stepnamemap mapstep
		       ))
	 )
    ;; recursive scan of data & steps to fill the mapdata associating
    ;; each data with its printable name and mapstep associating each
    ;; step with its printable name
    (letrec 
	( (scandata 
	   (lambda (data)
	     (debug "mg_altdraw_graphviz/scandata data=" data)
	     (assert_msg "mg_altdraw_graphviz.scandata check data" (is_a data class_matched_data))
	     (let ( (oldname ( (mapobject_get mapdata data) ))
		    )
	       (if oldname
		   (progn 
		     (debug "mg_altdraw_graphviz/scandata found oldname" oldname)
		     (return oldname))))
	     (let ( (nambuf (make_strbuf discr_strbuf))
		    (msymb (unsafe_get_field :mdata_symb data))
		    (:long datacnt (+i 1 (get_int datacountbox)))
		    (msteps (unsafe_get_field :mdata_steps data))
		    (symbname (get_field :named_name msymb))
		    )
	       (add2out nambuf ##{mdata_$DATACNT#_$SYMBNAME}#)
	       (put_int datacountbox datacnt)
	       (if (is_a msymb class_cloned_symbol)
		   (let ( (:long clonrk (get_int (get_field :csym_urank msymb))) 
			  )
		     (add2out nambuf ##{__$CLONRK}#)))
	       (let ( (newname  (strbuf2string discr_string nambuf))
		      )
		 (mapobject_put mapdata data newname)
		 (debug "mg_altdraw_graphviz/scandata newname=" newname " updated mapdata=" mapdata)
	       (foreach_pair_component_in_list
		(msteps)
		(curpair curstep)
		(scanstep curstep))
	       (return newname)
	       )
	     )))
	  (scanstep 
	   (lambda (step)
	     (debug "mg_altdraw_graphviz/scanstep step=" step)
	     (assert_msg "mg_altdraw_graphviz.scanstep check step" (is_a step class_match_step))
	     (let ( (oldname (mapobject_get mapstep step)) 
		    )
	       (if oldname
		   (progn
		     (debug "mg_altdraw_graphviz.scanstep found oldname" oldname)
		     (return oldname))))
	     (let ( (nambuf (make_strbuf discr_strbuf))
		    (:long mapcnt (mapobject_count mapstep))
		    (disnam (get_field :named_name (discrim step)))
		    ;; not every step has a data
		    (sdata (get_field :mstep_data step))
		    )
	       (code_chunk chunkdisnam
			   #{/*$CHUNKDISNAM*/ meltgc_add_strbuf ((melt_ptr_t)$NAMBUF,
								 melt_string_str ((melt_ptr_t)$DISNAM)
								 + strlen("CLASS_")) }#)
	       (add2sbuf_strconst nambuf "_ms_")
	       (add2sbuf_longdec nambuf (+i mapcnt 1))
	       (mapobject_put mapstep step (strbuf2string discr_string nambuf))
	       (if sdata (scandata sdata))
	       (scan_step_data step scandata ())
	       (scan_step_flag step scanflag ())
	       (let (
;;; these are checked get fields!!
		     (sthen (get_field :mstep_then step))
		     (selse (get_field :mstep_else step))
		     (sflag (get_field :mstep_flag step))
		     )
		 (if sthen (scanstep sthen))
		 (if selse (scanstep selse))
		 (if sflag (scanflag sflag))
		 ))))
	  (scanflag
	   (lambda (flag)
	     (debug "mg_altdraw_graphviz.scanflag flag=" flag)
	     (let ( (flstep (get_field :mflag_setstep flag))
		    )
	       (if flstep
		   (progn
		     (debug "mg_altdraw_graphviz.scanflag flstep" flstep)
		     (assert_msg "check flstep" (is_a flstep class_match_step))
		     (scanstep flstep)
		     ))
	       )))
	  )
      (debug "mg_altdraw_graphviz before scandata mdata=" mdata " scandata=" scandata)
      (assert_msg "check mdata" (is_a mdata class_matched_data))
      (scandata mdata)
      (debug "mg_altdraw_graphviz after scandata mdata=" mdata
	     " mapdata=" mapdata " mapstep=" mapstep)
      )
    (let (
	  (:long datacount 0)
	  (:long stepcount 0)
	  (tupdata (make_multiple discr_multiple (mapobject_count mapdata)))
	  (tupstep (make_multiple discr_multiple (mapobject_count mapstep)))
	  )
      (foreach_in_mapobject
       (mapdata)
       (curdata dataname)
       (multiple_put_nth tupdata datacount curdata)
       (setq datacount (+i 1 datacount))
       )
      (foreach_in_mapobject
       (mapstep)
       (curstep stepname)
       (multiple_put_nth tupstep stepcount curstep)
       (setq stepcount (+i 1 stepcount))
       )
      (let (
	    (sortupdata 
	     (multiple_sort
	      tupdata
	      (lambda (d1 d2)
		(let ( 
		      (sn1 (mapobject_get mapdata d1))
		      (sn2 (mapobject_get mapdata d2))
		      )
		  (cond 
		   ( (string< sn1 sn2) 
		     '-1)
		   ( (string> sn1 sn2)
		     '1)
		   (:else
		    '0
		    )))
		)
	      discr_multiple
	      ))
	    (sortupstep 
	     (multiple_sort
	      tupstep
	      (lambda (s1 s2)
		(let ( 
		      (sn1 (mapobject_get mapstep s1))
		      (sn2 (mapobject_get mapstep s2))
		      )
		  (cond 
		   ( (string< sn1 sn2) 
		     '-1)
		   ( (string> sn1 sn2)
		     '1)
		   (:else
		    '0
		    )))
		)
	      discr_multiple
	      ))
	    )
	;; draw the data nodes
	(debug "mg_altdraw_graphviz sortupdata" sortupdata)
	(foreach_in_multiple
	 (sortupdata)
	 (curdata :long dix)
	 (debug "mg_altdraw_graphviz curdata" curdata)
	 (assert_msg "mg_altdraw_graphviz check curdata" (is_a curdata class_matched_data))
	 (let ( 
	       (curdataname (mapobject_get mapdata curdata))
	       (datactype (unsafe_get_field :mdata_ctype curdata))
	       (datasymb (unsafe_get_field :mdata_symb curdata))
	       (datasteps (unsafe_get_field :mdata_steps curdata))
	       )
	   (add2out_indentnl nodebuf 0)
	   (add2out_string nodebuf curdataname)
	   (add2out_strconst nodebuf " [ margin=0, ")
	   (if (== curdata mdata)
	       (add2out_strconst nodebuf " style=\"bold,dashed,filled,rounded\", fillcolor=\"lightyellow\", ")
	     (add2out_strconst nodebuf " style=\"dashed,rounded\", "))
	   (add2out_strconst nodebuf "label=<<table border=\"0\" cellborder=\"0\"")
	   (add2out_strconst nodebuf " cellspacing=\"1\" cellpadding=\"1\">")
	   (add2out_indentnl nodebuf 0)
	   (add2out_strconst nodebuf "<tr><td><font color=\"green\" face=\"Times-Roman Bold\" point-size=\"7\">")
	   (add2out_string nodebuf curdataname)
	   (add2out_strconst nodebuf "</font></td> <td><font face=\"Courier\" point-size=\"6.5\">#")
	   (add2out_longhex nodebuf (obj_hash curdata))
	   (add2out_strconst nodebuf "</font></td> </tr>")
	   (add2out_indentnl nodebuf 0)
	   (add2out_strconst nodebuf "<tr><td><font color=\"darkgreen\" face=\"Times-Roman Italic\" point-size=\"7\">")
	   (add2out_string nodebuf (get_field :named_name datasymb))
	   (if (is_a datasymb class_cloned_symbol)
	       (let ( (:long clonum (get_int (unsafe_get_field :csym_urank datasymb)))
		      )
		 (add2out nodebuf ##{<font point-size="6">$CLONUM</font>}#)
		 ))
	   (add2out_strconst nodebuf "</font></td> <td><font color=\"brown\" face=\"Helvetica Oblique\" point-size=\"6\">")
	   (add2out_string nodebuf (get_field :named_name (get_field :ctype_keyword datactype)))
	   
	   (add2out_strconst nodebuf "</font></td> </tr>")
	   (add2out_strconst nodebuf "</table>> ];")
	   (add2out_indentnl nodebuf 0)
;;; output edges to the steps
	   (foreach_pair_component_in_list
	    (datasteps)
	    (pairstep curstep)
	    (add2out_indentnl edgebuf 0)
	    (add2out_string edgebuf curdataname)
	    (add2out_strconst edgebuf " /*data*/ -> /*step*/ ")
	    (add2out_string edgebuf (mapobject_get mapstep curstep))
	    (add2out_strconst edgebuf " [ arrowhead=open, color=blueviolet, style=dotted ];")
	    )
	   )
	 )
	;; draw the step nodes
	(debug "mg_altdraw_graphviz sortupstep" sortupstep)
	(foreach_in_multiple
	 (sortupstep)
	 (curstep :long dix)
	 (debug "mg_altdraw_graphviz curstep" curstep)
	 (assert_msg "mg_altdraw_graphviz check curstep" (is_a curstep class_match_step))
	 (let ( 
	       (curstepname (mapobject_get mapstep curstep))
	       )
	   (assert_msg "mg_altdraw_graphviz check curstepname" (is_string curstepname))
	   (add2out_indentnl nodebuf 0)
	   (add2out_string nodebuf curstepname)
	   (add2out_strconst nodebuf " [ margin=0, ")
	   (if (is_a curstep class_match_step_success_when_flag)
	       (add2out_strconst nodebuf " style=\"filled\", bgcolor=\"palegreen\", ")
	     )
	   (add2out_strconst nodebuf "label=<<table border=\"1\" cellborder=\"1\"")
	   (add2out_strconst nodebuf " cellspacing=\"1\" cellpadding=\"1\">")
	   (add2out_indentnl nodebuf 0)
	   (add2out_strconst nodebuf "<tr><td><font color=\"blue\" face=\"Times-Roman Bold\" point-size=\"7\">")
	   (add2out_string nodebuf curstepname)
	   (add2out_strconst nodebuf "</font></td> <td><font face=\"Courier\" point-size=\"6\">#")
	   (add2out_longhex nodebuf (obj_hash curstep))
	   (add2out_strconst nodebuf "</font></td> </tr>")
	   (add2out_indentnl nodebuf 0)
	   (matchgraphic_altstep curstep mg)
	   (add2out_strconst nodebuf "</table>> ];")
	   (add2out_indentnl nodebuf 0)
	   )
	 )
	;; output the file
	(let (
	      )
	  (code_chunk 
	   outputmgfile
	   #{ /* $outputmgfile start */
	   time_t nowt = 0		;
	   char nowbuf[60]		;
	   FILE* dotfil = 
	   fopen (melt_string_str ((melt_ptr_t) $DOTFILENAME), "w") ;
	   if (!dotfil) 
	   melt_fatal_error ("failed to open matchdot file %s - %m", 
			     melt_string_str ((melt_ptr_t) $DOTFILENAME)) ;
	   fprintf (dotfil, "// melt matchdot file %s\n", 
			    melt_string_str ((melt_ptr_t) $DOTFILENAME)) ;
	   time (&nowt)			;
	   memset (nowbuf, 0, sizeof(nowbuf)) ;
	   strftime (nowbuf, sizeof(nowbuf)-1,
			     "%Y %b %d %Hh%M",
			     localtime (&nowt))			;
	   fprintf (dotfil, "// generated %s\n", nowbuf)	;
	   fprintf (dotfil, "digraph meltmatchalt_%lx {", $MDATAHASH) ;
	   fprintf (dotfil, " graph [ label=<<font color='firebrick' point-size='9' face='Helvetica Bold'>Melt Alt Match %s ** %s</font>>,",
			    lbasename (melt_string_str ((melt_ptr_t) $DOTFILENAME)),
			    nowbuf)				    ;
	   fprintf (dotfil," pad=\"0.5\", margin=\"0.3\" ];\n")	    ;
	   fprintf (dotfil, " node [ shape=\"box\", fontsize=\"9\" ];\n") ;
	   melt_putstrbuf (dotfil, (melt_ptr_t) $NODEBUF) ;
	   fprintf (dotfil, "\n /// edges\n")		  ;
	   melt_putstrbuf (dotfil, (melt_ptr_t) $EDGEBUF) ;
	   fprintf (dotfil, "\n} // eof %s\n", melt_string_str ((melt_ptr_t) $DOTFILENAME)) ;
	   fclose (dotfil)		;
	   /* $outputmgfile end */
	   }#)
	  )))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; 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_or_clear
 class_normtester_or_initial_clear
 class_normtester_or_transmit
 class_normtester_same
 class_normtester_success
 class_normtester_tuple
 class_nrep_match
 ;;
 ;; for alternate matching
 class_match_case
 class_match_flag
 class_match_normalization_context
 class_match_step
 class_match_step_clear
 class_match_step_flag_conjunction 
 class_match_step_flag_disjunction 
 class_match_step_flag_operation 
 class_match_step_flag_set
 class_match_step_success_when_flag
 class_match_step_test
 class_match_step_test_group
 class_match_step_test_instance
 class_match_step_test_matcher
 class_match_step_test_multiple
 class_match_step_test_variable
 class_match_step_then
 class_match_step_with_data
 class_match_step_with_flag
 class_matched_binding
 class_matched_data
 class_matched_normal_data
 class_matching_context
 ;;
 class_nrep_matchalt
 class_nrep_jump_when_is_a
 class_nrep_match_data_action
 class_nrep_match_data_clear
 class_nrep_match_data_finalizer
 class_nrep_match_data_initializer
 class_nrep_match_flag
 class_nrep_match_jump
 class_nrep_match_label
 class_nrep_match_label_end
 class_nrep_matched_data
 )

;;; export our values
(export_values
 scan_pattern
 normal_pattern
 )

;; eof warmelt-normatch.melt