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

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

    This file is part of GCC.

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

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

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

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

;;    This file is the fourth part of a bootstrapping compiler for the
;;    basilys/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 expressioon
	   pctn_env			;the environment
;; mapping symbols to patternvars
	   pctn_mapatvar		;objmap of patternvars
	   pctn_mapatcst		;objmap of patternconst
	   pctn_bindlist		;binding list
	   ))

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


;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; scanning nil
(defun scanpat_nil (recv psloc ctyp pcn)
  (debug_msg recv "scanpat_nil recv")
  (assert_msg "check nil recv" (null recv))
  (assert_msg "check pcn" (is_a pcn class_patterncontext))
)
(install_method discr_nullrecv scan_pattern scanpat_nil)

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; 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" ())
))
(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 pcn" (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)) )
    (error_strv psloc 
		"unimplemented scan_pattern for pattern " myclassname)
    (assert_msg "catchall scan_pattern unimplemented" ())
))
(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 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)))
	 (bindlist (unsafe_get_field :pctn_bindlist pcn))
	 (env (unsafe_get_field :pctn_env pcn))
	 (rectyp (get_ctype recv env))
	 )
    (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))
	  ))
    (assert_msg "check bindlist" (is_list bindlist))
    (cond 
     ( (not (is_object sconst))
       (debug_msg sconst "scanpat_srcpatconst nonobj literal const")
       (return)
       )
     ( (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))
	(return)
	))
     (:else
	(debug_msg mcst "scanpat_srcpatconst got mcst")
	(return)
      ))
    ))
(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))
  (assert_msg "check recv" (is_a recv class_srcpattern_composite))
  (debug_msg recv "scanpat_srcpatcomposite recv")
  (let ( (sloc (unsafe_get_field :src_loc recv))
	 (soper (let ((sop (unsafe_get_field :spac_operator recv)))
		  (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 ctyp" (is_a ctyp class_ctype))
    (assert_msg "check matctyp" (is_a matctyp class_ctype))
    (cond ((!= ctyp matctyp)
	   (error_strv sloc "invalid ctype in composite partner - expecting"
		       (unsafe_get_field :named_name matctyp))
	   (warning_strv sloc "got ctype"
			 (unsafe_get_field :named_name ctyp))
	   (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")
     (foreach_in_multiple
      (souts)
      (pout :long ix)
      (if (null pout)
	  (progn
	    (debug_msg discr_nullrecv "scanpat_srcpatcomposite null pout discr_nullrecv")
	    (debug_msg discr_anyrecv "scanpat_srcpatcomposite null pout discr_anyrecv")
	    ))
      (debug_msg pout "scanpat_srcpatcomposite pout")
      (scan_pattern pout sloc ctyp pcn)
      )
     (debug_msg recv "scanpat_srcpatcomposite end recv")
     )))
(install_method class_srcpattern_composite scan_pattern scanpat_srcpatcomposite)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; backpoints are "backtracking" points in matching nreps
(defclass class_nrep_backpoint
  :super class_nrep_typexpr
  :fields (nbkp_do
	   nbkp_fail))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; any testpoints 
(defclass class_nrep_testpoint
  :super class_nrep_typexpr
  :fields (ntsp_failbp			;backpoint for failure
	   ntsp_succp			;success point
	   ntsp_test			;normal tested expression
))

;;; testpoint with matcher
(defclass class_nrep_testp_matcher
  :super class_nrep_testpoint
  :fields (ntsm_matcher			;the matcher
	   ntsm_binds			;the local bindings
))

;; testpoint for is_a
(defclass class_nrep_testp_isa
  :super class_nrep_testpoint
  :fields (ntsi_class			;tested is a class
))

;; testpoint for exact discrim
(defclass class_nrep_testp_discrim
  :super class_nrep_testp_isa
  :fields (
	   ))

;; conditional testpoint
(defclass class_nrep_testp_cond
  :super class_nrep_testpoint
  :fields (ntsc_cond			;the condition
))


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

;;; selector to normalize a pattern
;;; reciever is the pattern to normalize
;;; arguments are
;;; the list of src patterns
;;; the list of test points
;;; the pattern context
(defselector normal_pattern class_selector)


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

;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;
;;; catch-all for normpat any reciever (by failing)
(defun normpat_anyrecv (recv spatlist testptlist 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 spatlist testptlist 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 cmatcher pattern
(defun normpat_cmatchpat (recv spatlist testptlist pcn)
  (debug_msg recv "normpat_cmatchpat recv")
  (debug_msg spatlist "normpat_cmatchpat spatlist")
  (debug_msg testptlist "normpat_cmatchpat testptlist")
  (debug_msg pcn "normpat_cmatchpat pcn")
  (assert_msg "check pcn" (is_a pcn class_patterncontext))
  (assert_msg "check recv" (is_a recv class_srcpattern_cmatch))
  (let (
	(sloc (get_field :src_loc recv))
	(cmat (get_field :spac_operator recv))
	(inargs (get_field :spac_inargs recv))
	(outargs (get_field :spac_outargs recv))
	(env (unsafe_get_field :pctn_env pcn))
	(ncx (unsafe_get_field :pctn_normctxt pcn))
	(bindlist (unsafe_get_field :pctn_bindlist pcn))
	)
    (assert_msg "check cmat" (is_a cmat class_cmatcher))
    (debug_msg inargs "normpat_cmatchpat inargs")
    (debug_msg cmat "normpat_cmatchpat cmat")
    (multicall
     (nins bindins)
     (normalize_tuple inargs env ncx sloc)
     (debug_msg nins "normpat_cmatchpat nins")
     (debug_msg bindins "normpat_cmatchpat bindins")
     (if bindins (list_append2list bindlist bindins))
     (let ( (curtestp (instance class_nrep_testp_matcher
				:nrep_loc sloc
				:nexpr_ctyp (get_field :amatch_matchbind cmat)
				:ntsp_succp ()
				:ntsp_test ()
				:ntsm_matcher cmat
				:ntsm_binds ()
				))
	    )
       (debug_msg curtestp "normpat_cmatchpat curtestp")
       )
     (assert_msg "normpat_cmatchpat @@NOT IMPLEMENTED@@" ())
     (compile_warning "normpat_cmatchpat INCOMPLETE" ())
     )
    ))
(install_method class_srcpattern_cmatch normal_pattern normpat_cmatchpat)
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; 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))
	 (spatlist (make_list discr_list))
	 (testptlist (make_list discr_list))
	 )
    (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")
       (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))
	      (bindlist (make_list discr_list))
	      (pcn (instance class_patterncontext
			     :pctn_normctxt ncx
			     :pctn_src recv
			     :pctn_env env
			     :pctn_mapatvar mapvar
			     :pctn_mapatcst mapcst
			     :pctn_bindlist bindlist
			     ))
	      )
	  (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 spatlist testptlist pcn)
	  (debug_msg curcas "normexp_match curcas after normal_pattern")
	  )
	)				;end foreach_in_multiple
       (debug_msg tupvarmap "normexp_match tupvarmap")
       (debug_msg tupcstmap "normexp_match tupcstmap")
       (debug_msg tupbindlist "normexp_match tupbindlist")
       (assert_msg "unimplemented normexp_match" ())
       (compile_warning "@@unimplemented normexp_match" ())
       ))))

  
(install_method class_src_match normal_exp normexp_match)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; export our classes
(export_class
 class_patterncontext
)

;;; export our values
(export_values
  scan_pattern
  normal_pattern
 )

;; eof warmelt-normatch.bysl