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

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

    This file is part of GCC.

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

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

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

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

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


;;; class for the context of normalization of patterns
(defclass class_patterncontext
  :super class_root
  :fields (pctn_normctxt		;the class_normcontext
	   pctn_src			;the source match expressioon
	   pctn_env			;the current environment
	   ;; mapping symbols to patternvars
	   pctn_mapatvar		;objmap of patternvars
	   pctn_mapatcst		;objmap of patternconst
	   ;; binding list for input arguments in matcher
	   pctn_bindlist		;binding list 
	   ;; mapping matched stuff with list of normtesters
	   pctn_stuffmap
	   ;; mapping pattern variables to local occurrences 
	   pctn_pvarlocmap
	   ;; list of tests
	   pctn_tests
	   ))

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



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


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

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;; scanning or pattern
(defun scanpat_srcpator (recv psloc ctyp pcn)
  (debug_msg recv "scanpat_srcpator recv")
  (assert_msg "check pcn" (is_a pcn class_patterncontext))
  (assert_msg "check recv" (is_a recv class_srcpattern_or))
  (let ( (sloc (unsafe_get_field :src_loc recv))
	 (sdisj (unsafe_get_field :orpat_disj recv))
	 )
    (foreach_in_multiple
     (sdisj)
     (dis :long ix)
     (scan_pattern dis sloc ctyp pcn)
     )
    (debug_msg recv "scanpat_srcpator end recv")
    ))
(install_method class_srcpattern_or scan_pattern scanpat_srcpator)

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

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

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


;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;; scanning an as pattern
(defun scanpat_srcpatas (recv psloc ctyp pcn)
  (debug_msg recv "scanpat_srcpatas recv")
  (debug_msg ctyp "scanpat_srcpatas ctyp")
  (assert_msg "check pcn" (is_a pcn class_patterncontext))
  (assert_msg "check recv" (is_a recv class_srcpattern_as))
  (let ( (sloc (unsafe_get_field :src_loc recv))
	 (asvar (unsafe_get_field :aspat_varpat recv))
	 (asubp (unsafe_get_field :aspat_subpat recv))
	 (mapvar (unsafe_get_field :pctn_mapatvar pcn))
	 (mvar (mapobject_get mapvar asvar))
	 )
    (if (null mvar)
	(progn
	  (mapobject_put mapvar asvar recv)
	  (debug_msg asvar "scanpat_srcpatasr got new asvar")
	  ))
    (scan_pattern asubp sloc ctyp pcn)
    ))
(install_method class_srcpattern_as scan_pattern scanpat_srcpatas)


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

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;; scanning a pattern object or instance
(defun scanpat_srcpatobject (recv psloc ctyp pcn)
  (debug_msg recv "scanpat_srcpatobject recv")
  (assert_msg "check pcn" (is_a pcn class_patterncontext))
  (assert_msg "check recv" (is_a recv class_srcpattern_object))
  (let ( (sloc (unsafe_get_field :src_loc 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_srcfieldpattern))
     (let ( (fld (let ( ( f (get_field :spaf_field fldpa)) )
		   (assert_msg "check fld" (is_a f class_field))
		   f))
	    (flcla (get_field :fld_ownclass fld))
	    (fpat (unsafe_get_field :spaf_pattern fldpa))
	    )
       (cond ( (not (subclass_or_eq scla flcla))
	       (error_strv sloc "bad field in object pattern"
			   (unsafe_get_field :named_name fld))
	       (inform_strv sloc "class in pattern is" (get_field :named_name scla))
	       (inform_strv sloc "class of field is" (get_field :named_name flcla))
	       (return)))
       (scan_pattern fpat sloc ctype_value pcn)
       )
     )
    (debug_msg recv "scanpat_srcpatobject end recv")
    )
  )
(install_method class_srcpattern_object scan_pattern scanpat_srcpatobject)


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

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

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


(defselector normal_pattern class_selector)


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

;; all the testers share a common superclass
(defclass class_normtester_any 
  :super class_nrep_expr	;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
	   ))


;;; the tester wrapping or.  Needed to share the same ntest_then
;;; between disjuncts
(defclass class_normtester_disjunction
  :super class_normtester_any
  :fields (ntdisjuncts			;the tuple of disjunct tests
	   )
)

;; 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)
	   ))
 
;; test for same (ie identical) stuff
(defclass class_normtester_same
  :super class_normtester_any
  :fields (ntsame_identical		;checked normal stuff
	   ))

;; test for matcher
(defclass class_normtester_matcher
    :super class_normtester_any
    :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_any
    :fields (ntinst_class		;the class 
	     ;; a tuple similar to the class's fields
	     ntinst_fieldlocs		;the tuple of field locals or nil
	     ))

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

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


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

;; utility to set the newtester to the last of a ntest_then linked list
(defun set_newtester_lastthen (newtester testercont)
  (debug_msg newtester "set_newtester_lastthen newtester")
  (assert_msg "check newtester" (is_a newtester class_normtester_any))
  (assert_msg "check testercont" (is_a testercont class_container))
  (let ( (curtester (get_field :container_value testercont)) )
    (forever 
     lastesterloop
     ;; 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))))
    (put_fields testercont :container_value curtester)
    (put_tester_then curtester newtester)
    (debug_msg testercont "set_newtester_lastthen end testercont")
    ))


;; utility to set the newtester to the last of a ntest_else linked list
(defun set_newtester_lastelse (newtester testercont)
  (debug_msg newtester "set_newtester_lastelse newtester")
  (assert_msg "check newtester" (is_a newtester class_normtester_any))
  (assert_msg "check testercont" (is_a testercont class_container))
  (let ( (curtester (get_field :container_value testercont)) )
    (forever 
     lastesterloop
     ;; indeed a safe get_field to handle the nil case!
     (let ( (nextester (get_field :ntest_else curtester)) )
       (if (is_a nextester class_normtester_any)
	   (setq curtester nextester)
	 (exit lastesterloop))))
    (put_fields testercont :container_value curtester)
    (put_fields curtester :ntest_else newtester)
    (let ( (fromnew (get_field :ntest_comefrom newtester)) )
      (list_append fromnew curtester))
    (debug_msg testercont "set_newtester_lastelse testercont")
    ))

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

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

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

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; normalize variable pattern
(defun normpat_variablepat (recv nmatch hdler pcn)
  (debug_msg recv "normpat_variablepat recv")
  (debug_msg nmatch "normpat_variablepat nmatch")
  (assert_msg "check recv" (is_a recv class_srcpattern_variable))
  (assert_msg "check pcn" (is_a pcn class_patterncontext))
  (let ( (stuffmap (get_field :pctn_stuffmap pcn))
	 (pvarmap (get_field :pctn_pvarlocmap pcn)) 
	 (psloc (get_field :src_loc (get_field :pctn_src pcn)))
	 (sloc (get_field :src_loc recv))
	 (patvar (get_field :spat_var recv))
	 (tstuff (mapobject_get stuffmap nmatch))
	 (lococc (mapobject_get pvarmap patvar))
	 (env (get_field :pctn_env pcn))
	 (ncx (get_field :pctn_normctxt pcn))
	 (testlist (get_field :pctn_tests pcn))
	 )
    (debug_msg tstuff "normpat_variablepat tstuff")
    (debug_msg lococc "normpat_variablepat lococc")
    (debug_msg patvar "normpat_variablepat patvar")
    (if lococc
	;; patvar already bound, generate a same test if not already found
	(let (
	      (tester ())
	      (curhdler hdler)
	      )
	  (assert_msg "check lococc" (is_a lococc class_nrep_locsymocc))
	  (forever 
	   loopstuff
	   (debug_msg tstuff "normpat_variablepat 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)
			       (put_fields tstuff :ntest_else tester)
			       (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))
		    )
	       (register_new_normtester newtester pcn)
	       (debug_msg newtester "normpat_variablepat newtester")
	       (setq tester newtester)
	       (list_append testlist newtester)
	       (curhdler newtester)
	       (exit loopstuff)
	       )
	     )
	    )
	   )
	  )
      ;; else patvar unbound, so bind it 
      (let ( (ctyp (get_ctype nmatch env))
	     (cbind (instance class_normlet_binding
			      :letbind_loc sloc
			      :binder patvar
			      :letbind_type ctyp
			      :letbind_expr nmatch
			      ))
	     (clocc (instance class_nrep_locsymocc
			      :nrep_loc sloc
			      :nocc_ctyp ctyp
			      :nocc_symb patvar
			      :nocc_bind cbind))
	     )
	(debug_msg ctyp "normpat_variablepat ctyp")
	(debug_msg clocc "normpat_variablepat new clocc")
	;; put the clocc in the symbol cache map
	(mapobject_put (get_field :nctx_symbcachemap ncx) patvar clocc)
	(mapobject_put pvarmap patvar clocc)
	(debug_msg patvar "normpat_variablepat updated patvar")
	(debug_msg clocc "normpat_variablepat updated clocc")
	(debug_msg pvarmap "normpat_variablepat updated pvarmap")
	))
    ))
(install_method class_srcpattern_variable normal_pattern normpat_variablepat)
;;;;;;;;;;;;;;;;





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

;;; normalize an as pattern
(defun normpat_aspat  (recv nmatch hdler pcn)
  (debug_msg recv "normpat_aspat recv")
  (debug_msg nmatch "normpat_aspat nmatch")
  (assert_msg "check recv" (is_a recv class_srcpattern_as))
  (assert_msg "check pcn" (is_a pcn class_patterncontext))
  (let (
	(sloc (get_field :src_loc recv))
	(aspat (get_field :aspat_varpat recv))
	(subpat (get_field :aspat_subpat recv))
	(testvarcont (instance class_container))
	)
    (debug_msg aspat "normpat_aspat before normalizing aspat")
    (assert_msg "check aspat" (is_a aspat class_srcpattern_variable))
    (normal_pattern aspat nmatch
		    (lambda (tester) (put_fields testvarcont :container_value tester) (hdler tester)) 
		    pcn)
    (let ( (testvar (unsafe_get_field :container_value testvarcont)) 
	   )
      (debug_msg testvar "normpat_aspat testvar")
      (debug_msg subpat "normpat_aspat subpat")
      (normal_pattern 
       subpat nmatch
       (if testvar
	   (lambda (subtester) 
	     (debug_msg subtester "normpat_aspat subtester with testvar")
	     (set_newtester_lastthen subtester testvarcont)
	     )
	 (lambda (subtester)
	   (debug_msg subtester "normpat_aspat subtester without testvar")
	   (hdler subtester)
	   ))
       pcn)
      (debug_msg recv "normpat_aspat end recv")
      )))
(install_method class_srcpattern_as normal_pattern normpat_aspat)





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



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




;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; normalize a disjunction [or of subpatterns]
(defun normpat_orpat (recv nmatch hdler pcn)
  (debug_msg recv "normpat_orpat recv")
  (shortbacktrace_dbg "normpat_orpat called" 16)
  (debug_msg nmatch "normpat_orpat nmatch")
  (debug_msg pcn "normpat_orpat pcn")
  (assert_msg "check pcn" (is_a pcn class_patterncontext))
  (assert_msg "check recv" (is_a recv class_srcpattern_or))
  (let (
	(sloc (get_field :src_loc recv))
	(disjpats (get_field :orpat_disj recv))
	(testercont (instance class_container))
	(lisubtesters (make_list discr_list))
	(testlist (get_field :pctn_tests pcn))
	(subhdler
	 (lambda (newtester) 
	   (debug_msg newtester "normpat_orpat.subhdler newtester")
	   (debug_msg testercont "normpat_orpat.subhdler testercont")
	   (if newtester
	       (progn
		 (assert_msg "check newtester" (is_a newtester class_normtester_any))
		 (list_append lisubtesters newtester)))
	   (let ( (prevtester (get_field :container_value testercont)) )
	     (cond
	      ((is_a prevtester class_normtester_any)
	       (debug_msg prevtester "normpat_orpat.subhdler prevtester")
	       (set_newtester_lastelse newtester testercont)
	       )
	      (:else	   
	       (debug_msg newtester "normpat_orpat.subhdler before calling hdler")
	       (put_fields testercont :container_value newtester)
	       (debug_msg newtester "normpat_orpat.subhdler after calling hdler")
	       ))
	     (debug_msg testercont "normpat_orpat.subhdler done testercont")
	     )))
	) 
    (foreach_in_multiple 
     (disjpats)
     (subpat :long subix)
     (debug_msg testercont "normpat_orpat testercont")
     (debug_msg subpat "normpat_orpat subpat before normal_pattern")
     (normal_pattern subpat nmatch subhdler pcn)
     (debug_msg subpat "normpat_orpat subpat after normal_pattern")
     (debug_msg testercont "normpat_orpat testercont after normal_pattern")
     )
    (let  (
	   (subtesters (list_to_multiple lisubtesters))
	   (:long nbsubtesters (multiple_length subtesters))
	   )
      (debug_msg subtesters "normpat_orpat subtesters")
      (if (<i nbsubtesters 2)
	  (warning_plain sloc "this OR pattern has less than two tests so is degenerated")
	;; we might check for an equivalent disjunction, but it is probably useless in practice...
	(let ( (disjtester (instance class_normtester_disjunction 
				     :nrep_loc sloc
				     :ntest_matched nmatch
				     :ntest_then ()
				     :ntest_else (multiple_nth subtesters 0)
				     :ntest_comefrom (make_list discr_list)
				     :ntdisjuncts subtesters
			    )) )
	  (debug_msg disjtester "normpat_orpat disjtester")
	  (register_new_normtester disjtester pcn)
	  (hdler disjtester)
	  (list_append testlist disjtester)
	  (debug_msg disjtester "normpat_orpat handled disjtester")
	  ))
      )
    )
  (debug_msg recv "normpat_orpat recv end")
  )
(install_method class_srcpattern_or normal_pattern normpat_orpat)


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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; 
;;;; normalize a constant pattern
(defun normpat_constpat (recv nmatch hdler pcn)
  (debug_msg recv "normpat_constpat recv")
  (debug_msg nmatch "normpat_constpat nmatch")
  (debug_msg pcn "normpat_constpat pcn")
  (assert_msg "check pcn" (is_a pcn class_patterncontext))
  (assert_msg "check recv" (is_a recv class_srcpattern_constant))
  (let (
	(sloc (get_field :src_loc recv))
	(sconst (get_field :spat_constx recv))
	(stuffmap (get_field :pctn_stuffmap pcn))
	(pvarmap (get_field :pctn_pvarlocmap pcn)) 
	(psloc (get_field :src_loc (get_field :pctn_src pcn)))
	(tstuff (mapobject_get stuffmap nmatch))
	(env (get_field :pctn_env pcn))
	(ncx (get_field :pctn_normctxt pcn))
	(testlist (get_field :pctn_tests pcn))
	(mapcst (get_field :pctn_mapatcst pcn))
	)
;;; the constant has already been normalized in scanpat_srcpatconst
    (debug_msg tstuff "normpat_constpat tstuff")
    (let (
	  (tester ())
	  (curhdler hdler)
	  (nconst (if (is_object sconst) (mapobject_get mapcst sconst) sconst))
	  )
      (debug_msg nconst "normpat_constpat nconst")
      (forever 
       loopstuff
       (debug_msg tstuff "normpat_constpat tstuff")
       (cond
	( (== (get_field :ntsame_identical tstuff) nconst)
	  (setq tester tstuff)
	  (exit loopstuff))
	( (is_a tstuff class_normtester_any)
	  (setq tstuff (get_field :ntest_else tstuff))
	  (setq curhdler (lambda (tester)
			   (put_fields tstuff :ntest_else tester)
			   (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))
		)
	   (register_new_normtester newtester pcn)
	   (debug_msg newtester "normpat_constpat newtester")
	   (setq tester newtester)
	   (list_append testlist newtester)
	   (curhdler newtester)
	   (exit loopstuff)
	   )
	 )
	)
       )				;end forever
      (debug_msg tester "normpat_constpat got tester")
      )
    )
  )
(install_method class_srcpattern_constant normal_pattern normpat_constpat)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; normalize a match
(defun normexp_match (recv env ncx psloc)
  (assert_msg "check match recv" (is_a recv class_src_match))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check nctxt" (is_a ncx class_normcontext))
  (debug_msg recv "normexp_match recv")
  (let ( (sloc (unsafe_get_field :src_loc 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))
	 (tupbindlist (make_multiple discr_multiple nbcases))
	 ;; the bindlist & the stuffmap are shared for all match cases
	 (stuffmap (make_mapobject discr_mapobjects 
				   (+i 20 (*i 5 nbcases))))
	 (bindlist (make_list discr_list))
	 (testlist (make_list discr_list))
	 (wholectype ())		;the ctype of the whole match
	 (oldtester ())			;the previous tester
	 )
    (debug_msg smatsx "normexp_match smatsx")
    (multicall
     (nmatx nbindmatx)
     (normal_exp smatsx env ncx sloc)
     (debug_msg nmatx "normexp_match nmatx")
     (debug_msg scases "normexp_match scases")
     (let ( (ctyp (get_ctype nmatx env)) 
	    )
       (debug_msg ctyp "normexp_match ctyp")
       ;; if the matched stuff is not an object, it is a constant, so
       ;; make a binding for it
       (if (not (is_object nmatx))
	   (let (
		 (csym (clone_symbol '_matched_))
		 (cbind (instance class_normlet_binding
				  :letbind_loc sloc
				  :binder csym
				  :letbind_type ctyp
				  :letbind_expr nmatx))
		 (clocc (instance class_nrep_locsymocc
				  :nrep_loc sloc
				  :nocc_ctyp ctyp
				  :nocc_symb csym
				  :nocc_bind cbind))
		 )
	     (assert_msg "check no binding" (null nbindmatx))
	     ;; put the clocc in the symbol cache map
	     (mapobject_put (get_field :nctx_symbcachemap ncx) csym clocc)
	     (setq nbindmatx (list1 cbind))
	     (setq nmatx clocc)
	     ))
       ;; if no binding list, make an empty one
       (if (null nbindmatx) (setq nbindmatx (make_list discr_list)))
       (foreach_in_multiple
	(scases)
	(curcas :long ix)
	(debug_msg curcas "normexp_match curcas")
	(assert_msg "check curcas" (is_a curcas class_src_casematch))
	(let ( 
	      (curloc (unsafe_get_field :src_loc curcas))
	      (curpat (unsafe_get_field :scam_patt curcas))
	      (curbody (unsafe_get_field :scam_body curcas))
	      (mapvar (make_mapobject discr_mapobjects 13))
	      (mapcst (make_mapobject discr_mapobjects 11))
	      (pvarmap (make_mapobject discr_mapobjects 23))
	      (pcn (instance class_patterncontext
			     :pctn_normctxt ncx
			     :pctn_src recv
			     :pctn_env env
			     :pctn_mapatvar mapvar
			     :pctn_mapatcst mapcst
			     :pctn_bindlist bindlist
			     :pctn_stuffmap stuffmap
			     :pctn_pvarlocmap pvarmap
			     :pctn_tests testlist
			     ))
	      (ntestcont (instance class_container)) ;container for tester
	      )
	  ;; I am not entirely sure of this assert! Perhaps there maybe
	  ;; strange cases where curpat is null...
	  (assert_msg "normexp_match check curpat" curpat)
	  (scan_pattern curpat curloc ctyp pcn)
	  (debug_msg mapvar "normexp_match mapvar")
	  (debug_msg mapcst "normexp_match mapcst")
	  (debug_msg bindlist "normexp_match bindlist")
	  (multiple_put_nth tupvarmap ix mapvar)
	  (multiple_put_nth tupcstmap ix mapcst)
	  (multiple_put_nth tupbindlist ix bindlist)
	  (debug_msg curpat "normexp_match curpat before normal_pattern")
	  (normal_pattern 
	   curpat nmatx
	   (lambda (tester) 
	     (debug_msg tester "normexp_match.lambda tester")
	     (put_fields ntestcont :container_value tester))
	   pcn)
	  (debug_msg ntestcont "normexp_match ntestcont after normal_pattern")
	  (let ( (newenv (get_field :pctn_env pcn))
		 (pvarlocmap (get_field :pctn_pvarlocmap pcn))
		 (curtester (get_field :container_value ntestcont))
		 (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 ()
			    ))
		 )
	    ;; we don't register the success test
	    (debug_msg newenv "normexp_match newenv")
	    (debug_msg pvarlocmap "normexp_match pvarlocmap")
	    (debug_msg curcas "normexp_match curcas after normal_pattern")
	    (debug_msg curtester "normexp_match curtester after normal_pattern")
	    (debug_msg oldtester "normexp_match oldtester after normal_pattern")
	    (if (null curtester)
		(progn
		  (debug_msg curcas "normexp_match curcas for null curtester")
		  ;; curtester is null if the whole case is a joker,
		  ;; this should be the last case
		  (if (<i ix (-i (multiple_length scases) 1))
		      (warning_plain sloc "joker case in MATCH is not last"))
		  ))
	    (assert_msg "check curtester" (or (null curtester) (is_a curtester class_normtester_any)))
	    ;; loop on the ntest_then chain to add the success test at
	    ;; last, ensuring that there is no yet any success test
	    ;; there...
	    (forever
	     lastesterloop
	     (debug_msg curtester "normexp_match lastesterloop curtester")
	     (if (null curtester)
		 (exit lastesterloop))
	     (if (is_a curtester class_normtester_success)
		 (let ( (otherloc (get_field :nrep_loc curtester)) )
		   (warning_plain curloc "unreachable match case")
		   (inform_plain otherloc "this is the other successful case")
		   (exit lastesterloop)
		   ()))
	     (let ( (nextester (get_field :ntest_then curtester)) )
	       (if (is_a nextester class_normtester_any)
		   (progn 
		     (setq curtester nextester)
		     (debug_msg curtester "normexp_match curtester becomes"))
		 (exit lastesterloop)))
	     )
	    ;; no curtester for a last joker pattern ....
	    (if (null curtester)
		(progn
		  (setq curtester newsuctester)
		  (debug_msg curtester "normexp_match no curtester so success")
		  ))
	    ;; if there is an oldtester, add the curtester as its last else case
	    (forever 
	     oldtesterloop
	     (if (null oldtester) (exit oldtesterloop))
	     (assert_msg "check oldtester" (is_a oldtester class_normtester_any))
	     (let ( (oldelse (unsafe_get_field :ntest_else oldtester)) )
	       (if (null oldelse)
		   (progn
		     (put_fields oldtester :ntest_else curtester)
		     (list_append (get_field :ntest_comefrom curtester) oldtester)
		     (debug_msg oldtester "normexp_match updated oldtester")
		     (exit oldtesterloop))
		 (setq oldtester oldelse))
	       ))
	    ;; always set the oldtester to the curtester
	    (setq oldtester curtester)
	    ;; if the curtester is not the new success itself, put the
	    ;; new success as its then case
	    (if (!= curtester newsuctester)
		(put_tester_then curtester newsuctester))
	    ;;
	    (list_append testlist newsuctester)
	    (debug_msg curtester "normexp_match after lastesterloop curtester")
	    (debug_msg pcn "normexp_match pcn after lastesterloop")
	    (debug_msg pvarlocmap "normexp_match pvarlocmap")
	    (let ( (sortedvars (mapobject_sorted_attribute_tuple pvarlocmap)) 
		   (sortedbindings (make_multiple discr_multiple (multiple_length sortedvars)))
		   (freshnewenv (fresh_env newenv))
		   )
	      (debug_msg sortedvars "normexp_match sortedvars")
	      ;; we have to make a list of bindings based upon the sortedvars
	      (foreach_in_multiple
	       (sortedvars)
	       (svar :long svix)
	       (debug_msg svar "normexp_match svar")
	       (let ( (socc (mapobject_get pvarlocmap svar))
		      )
		 (debug_msg socc "normexp_match socc")
		 (assert_msg "check socc" (is_a socc class_nrep_locsymocc))
		 (let ( (sbind (unsafe_get_field :nocc_bind socc)) )
		   (debug_msg sbind "normexp_match sbind")
		   (multiple_put_nth sortedbindings svix sbind)
		   (put_env freshnewenv sbind)
		   )
		 ))
	      (debug_msg freshnewenv "normexp_match freshnewenv")
	      (debug_msg sortedbindings "normexp_match sortedbindings")
	      (assert_msg "check sortedbindings" (is_multiple sortedbindings))
	      (let ( (subindlist (make_list discr_list)) 
		     )
		(foreach_in_multiple
		 (sortedbindings)
		 (cursortbind :long sortbix)
		 (debug_msg cursortbind "normexp_match cursortbind")
		 (assert_msg "check cursortbind" 
			     (is_a cursortbind class_normlet_binding))
		 (list_append subindlist cursortbind)
		 )
		(multicall 
		 (nbody bindsbody)
		 (normalize_tuple curbody freshnewenv ncx curloc)
		 (debug_msg nbody "normexp_match nbody")
		 (debug_msg bindsbody "normexp_match bindsbody")
		 (assert_msg "check bindsbody" (is_list_or_null bindsbody))
		 (foreach_in_list
		  (bindsbody)
		  (bindbodypair curbindbody)
		  (debug_msg curbindbody "normexp_match curbindbody")
		  (list_append subindlist curbindbody)
		  )
		 (debug_msg subindlist "normexp_match final subindlist")
		 (let ( (wnlet (wrap_normal_letseq nbody subindlist curloc)) 
			(lastnbody (multiple_nth nbody -1))
			(lastctype (get_ctype lastnbody freshnewenv))
			)
		   (debug_msg wnlet "normexp_match wnlet")
		   (debug_msg lastnbody "normexp_match lastnbody")
		   (debug_msg lastctype "normexp_match lastctype")
		   (put_fields newsuctester 
			       :ntsuccess_do wnlet
			       )
		   (cond ( (null wholectype)
			   (setq wholectype lastctype))
			 ( (== lastctype ctype_void)
			   (setq wholectype ctype_void))
			 ( (== wholectype ctype_void)
			   ())
			 ( (!= wholectype lastctype)
			   (error_strv curloc "invalid type of match case" 
				       (get_field :named_name lastctype))
			   (inform_strv sloc "expected type of match case"
					(get_field :named_name wholectype)))
			 )
		   )
		 )
		)
	      )
	    )
	  )
	)				;end foreach_in_multiple
       (debug_msg tupvarmap "normexp_match tupvarmap")
       (debug_msg tupcstmap "normexp_match tupcstmap")
       (debug_msg tupbindlist "normexp_match tupbindlist")
       (debug_msg testlist "normexp_match testlist")
       (debug_msg stuffmap "normexp_match stuffmap")
       (let ( 
	     (teststupl (list_to_multiple testlist)) 
	     (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_normlet_binding
			      :letbind_loc sloc
			      :binder csym
			      :letbind_type wholectype
			      :letbind_expr nmatch))
	     )
	 (debug_msg csym "normexp_match csym")
	 (put_fields clocc :nocc_bind cbind)
	 (debug_msg clocc "normexp_match clocc")
	 ;; put the clocc in the symbol cache map
	 (mapobject_put (get_field :nctx_symbcachemap ncx) csym clocc)
	 ;; put the index of each test 
	 (foreach_in_multiple
	  (teststupl)
	  (curtest :long tstix)
	  (debug_msg curtest "normexp_match raw curtest")
	  (assert_msg "check curtest" (is_a curtest class_normtester_any))
	  (assert_msg "check tstix" (>=i tstix 0))
	  (messagenum_dbg "normexp_match testindex tstix" tstix)
	  (put_int curtest tstix)
	  (put_fields curtest :ntest_normatch nmatch)
	  (debug_msg curtest "normexp_match indexed curtest")
	  )
	 (unsafe_put_fields clocc :nocc_bind cbind)
	 (debug_msg nbindmatx "normexp_match before append nbindmatx")
	 (assert_msg "check nbindmatx" (is_list nbindmatx))
	 (list_append nbindmatx cbind)
	 (debug_msg nmatch "normexp_match nmatch")
	 (debug_msg cbind "normexp_match cbind")
	 (debug_msg nbindmatx "normexp_match final nbindmatx")
	 (return clocc nbindmatx)
	 )))))


(install_method class_src_match normal_exp normexp_match)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; export our classes
(export_class
 class_patterncontext
 class_normtester_any
 class_normtester_disjunction
 class_normtester_success
 class_normtester_same
 class_normtester_matcher
 class_normtester_instance
 class_nrep_match
 )

;;; export our values
(export_values
 scan_pattern
 normal_pattern
 )

;; eof warmelt-normatch.melt