path: root/gcc/testsuite/melt/t-treecode.melt

;; file t-treecode.melt -*- lisp -*- this sample code is GPLv3, it
;; will go into libmelt-ana-tree.melt as soon as it works.
#| run in buildir/gcc
 ln -sv $GCCMELT_SOURCE/gcc/testsuite/melt/t-treecode.melt

 ./cc1 -fmelt-mode=runfile @meltbuild-common.args -Iinclude/ \
    -fmelt-init=@melt-default-modules.quicklybuilt -fmelt-arg=t-treecode.melt \
     /dev/null -o /dev/null
## perhaps also: -fmelt-debugging=all -fmelt-out-descr-comment

or in a MELT module

gcc -fplugin=melt -fplugin-arg-melt-mode=runfile @meltbuild-common.args \
    -fplugin-arg-melt-init=@melt-default-modules.quicklybuilt -fplugin-arg-melt-arg=t-treecode.melt \
     -c -x c /dev/null -o /dev/null
|#
(comment "***
    Copyright  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/>.
***")

(module_is_gpl_compatible "GPLv3")


(let (      
      (:macro  gcc_tree_code (sexp env mexpander modctx)	      
	       (debug "gcc_tree_code:macro2" " sexp=" sexp)
	       (let (
		     (sloc (get_field :loca_location sexp))
		     (sexcont (get_field :sexp_contents sexp))
		     (xargs (expand_restlist_as_tuple sexcont env mexpander modctx))
		     (namecod (multiple_nth xargs 0))
		     (strcod (multiple_nth xargs 1))
		     (typcod (multiple_nth xargs 2))
		     (nargcod (multiple_nth xargs 3))
		     (nbargs (multiple_length xargs))
		     (namev (get_field :named_name namecod))
		     (treenamev (string4out discr_string "tree_" namev))
		     (treesymb (create_symbolstr treenamev))
		     (statesymb (create_symbolstr (string4out discr_string "treestate_" namev)))
		     )
		 (when (!=i 4 nbargs)
		   (error_at sloc "GCC_TREE_CODE need four arguments, got $1" xargs)
		   (return))
		 (debug "gcc_tree_code:macro2"
			" namecod=" namecod
			" strcod=" strcod
			" typcod=" typcod
			" nargcod=" nargcod
			"\n.. treesymb=" treesymb
			"\n.. bind:" (find_env env treesymb))
		 (assert_msg "check namev" (is_string namev) namev namecod sexp)
		 (unless (find_env env treesymb)
		   (cond
		    ;; tcc_exceptional, no automatic sub-trees
		    ( (== typcod 'tcc_exceptional)
		      (let
			  (
			   (xcmatchdoc
			    (let
				(
				 (d
				  (substitute_sexpr
				   '#{Generated tcc_exceptional $TREESYMB cmatcher.}#
				   (lambda (symb)
				     (debug "gcc_tree_code:macro2-lambdasubstdoc symb=" symb)
				     (if (== symb 'treesymb)
					 (get_field :named_name treesymb)
				       symb))))
				 )
			      (debug "gcc_tree_code:macro2" " sloc=" sloc " exceptional xcmatchdoc=" d)
			      d))
			   (xmatexp
			    (let
				(
				 (e
				  (substitute_sexpr
				   '#{ /* generated exceptional $TREESYMB tester ? */
				   $TR && TREE_CODE($TR) == $NAMECOD }#
				   (lambda (symb)
				     (debug "gcc_tree_code:macro2-lambdasubstexp symb=" symb)
				     (cond
				      ( (== symb 'treesymb)
					(clone_with_discriminant (get_field :named_name treesymb) discr_verbatim_string)
					)
				      ( (== symb 'namecod)
					(clone_with_discriminant (get_field :named_name namecod) discr_verbatim_string)
					)
				      (:else
				       symb)))
				   ))
				 )
			      (debug "gcc_tree_code:macro2" " sloc=" sloc " exceptional xmatexp=" e)
			      e))
			   (xcmatcher
			    `(defcmatcher ,treesymb
			       (:tree tr)
			       ()
			       ,statesymb
			       :doc ,xcmatchdoc
			       ;; match-expander
			       ,xmatexp
			       ))
			   (xexport `(export_values ,treesymb))
			   )
			(put_fields xcmatcher :loca_location sloc)
			(put_fields xexport :loca_location sloc)
			(debug "gcc_tree_code:macro2" " sloc=" sloc " exceptional xcmatcher=" debug_more xcmatcher
			       "\n.. xexport=" xexport)
			(let (
			      (rmatch (macroexpand_1 xcmatcher env mexpander modctx))
			      (rexport (macroexpand_1 xexport env mexpander modctx))
			      )
			  (debug "gcc_tree_code:macro2" " sloc=" sloc " exceptional rmatch=" rmatch
				 "\n.. rexport=" rexport)
			  (return rmatch (tuple rexport))
			  ))
		      )
		    ;; tcc_constant & tcc_declaration, without sub-trees
		    (
		     (or (== typcod 'tcc_constant)
			 (== typcod 'tcc_declaration)
			 )
		     (if (>i (get_int nargcod) 0)
			 (error_at sloc "GCC_TREE_CODE $1 of tcc_constant or tcc_declaration type with non-zero arity $2"
				   treesymb nargcod
				   ))
		     (let
			 (
			  (xcmatchdoc
			   (let
			       (
				(d
				 (substitute_sexpr
				  '#{Generated simple $TYPCOD $TREESYMB cmatcher.}#
				  (lambda (symb)
				    (debug "gcc_tree_code:macro2-lambdasubsttypcod symb=" symb)
				    (if (== symb 'typcod)
					(get_field :named_name typcod)
				      symb))))
				)
			     (debug "gcc_tree_code:macro2"" sloc=" sloc "; constdecl xcmatchdoc=" d)
			     d))
			  (xmatexp
			   (let
			       (
				(e
				 (substitute_sexpr
				  '#{ /* generated simple $TREESYMB tester ? */
				  $TR && TREE_CODE($TR) == $NAMECOD }#
				  (lambda (symb)
				    (debug "gcc_tree_code:macro2-lambdasubsttypcod symb=" symb)
				    (cond
				     ( (== symb 'treesymb)
				       (clone_with_discriminant (get_field :named_name treesymb) discr_verbatim_string)
				       )
				     ( (== symb 'namecod)
				       (clone_with_discriminant (get_field :named_name namecod) discr_verbatim_string)
				       )
				     (:else
				      symb)))
				  ))
				)
			     (debug "gcc_tree_code:macro2"" sloc=" sloc "; constdecl xmatexp=" e)
			     e))
			  (xcmatcher
			   `(defcmatcher ,treesymb
			      (:tree tr)
			      ()
			      ,statesymb
			      :doc ,xcmatchdoc
			      ;; match-expander
			      ,xmatexp
			      ))
			  (xexport `(export_values ,treesymb))
			  )
		       (put_fields xcmatcher :loca_location sloc)
		       (put_fields xexport :loca_location sloc)
		       (debug "gcc_tree_code:macro2" " sloc=" sloc "; constdecl xcmatcher=" debug_more xcmatcher
			      "\n.. xexport=" xexport)
		       (let (
			     (rmatch (macroexpand_1 xcmatcher env mexpander modctx))
			     (rexport (macroexpand_1 xexport env mexpander modctx))
			     )
			 (debug "gcc_tree_code:macro2" " sloc=" sloc "; rmatch=" rmatch
				"\n.. rexport=" rexport)
			 (return rmatch (tuple rexport))
			 ))
		     
		     )
		    ;; For fixed tcc_reference, tcc_expression,
		    ;; tcc_comparison, tcc_unary, tcc_binary,
		    ;; tcc_statement.  They use the arity fourth
		    ;; argument, and we extract sub-tree operands.
		    (
		     (or (== typcod 'tcc_reference)
			 (== typcod 'tcc_expression)
			 (== typcod 'tcc_unary)
			 (== typcod 'tcc_binary)
			 (== typcod 'tcc_statement)
			 )
		     (let
			 (
			  (xcmatchdoc
			   (let
			       (
				(d
				 (substitute_sexpr
				  '#{Generated fixed $TYPCOD $TREESYMB cmatcher of arity $NARGCOD.}#
				  (lambda (symb)
				    (debug "gcc_tree_code:macro2-lambdasubstfixed symb=" symb)
				    (cond
				     ( (== symb 'typcod)
				       typcod)
				     ( (== symb 'nargcod)
				       nargcod)
				     (:else symb))
				    )))
				)
			     (debug "gcc_tree_code:macro2" " sloc=" sloc "; fixed xcmatchdoc=" d)
			     d))
			  (xmatexp
			   (let
			       (
				(e
				 (substitute_sexpr
				  '#{ /* generated fixed $TREESYMB tester ? */
				  $TR && TREE_CODE($TR) == $NAMECOD }#
				  (lambda (symb)
				    (debug "gcc_tree_code:macro2-lambdasubstfixed symb=" symb)
				    (cond
				     ( (== symb 'treesymb)
				       (clone_with_discriminant (get_field :named_name treesymb) discr_verbatim_string)
				       )
				     ( (== symb 'namecod)
				       (clone_with_discriminant (get_field :named_name namecod) discr_verbatim_string)
				       )
				     ( (== symb 'nargcod)
				       nargcod)
				     (:else
				      symb)))
				  ))
				)
			     (debug "gcc_tree_code:macro2" " sloc=" sloc "; fixed xmatexp=" e)
			     e))
			  (xlistfill (make_list discr_list))
			  (tupopervar
			   (let ( (:long narity (get_int nargcod))
				  ( tv (make_multiple discr_multiple narity))
				  )
			     (foreach_long_upto
			      (1 narity)
			      (:long ix)
			      (let ( (:long previx (-i ix 1))
				     (opnamstr (string4out discr_string "TROPERAND" previx))
				     (opnamsymb (create_symbolstr opnamstr))
				     )
				(multiple_put_nth tv previx opnamsymb)
				(let ( (tr 'tr)
				       )
				  (add2list xlistfill ##{ $OPNAMSYMB = TREE_OPERAND($TR, $PREVIX)}#
					    ";\n")
				  )
				)
			      (debug "gcc_tree_code:macro2" " sloc=" sloc "; fixed tupopervar=" tv
				     "\n.. updated xlistfill=" xlistfill)
			      tv
			      )))
			  (xmatfill
			   (let ( (e (substitute_sexpr
				      '#{ /* generated fixed $TREESYMB filler ! */
				      $XLISTFILL
				      /* end of generated fixed $TREESYMB filler */}#
				      (lambda (symb)
					(debug "gcc_tree_code:macro2-lambdasubstfixfiller symb=" symb)
					(cond
					 ( (== symb 'treesymb)
					   (clone_with_discriminant (get_field :named_name treesymb) discr_verbatim_string)
					   )
					 ( (== symb 'xlistfill)
					   xlistfill)
					 (:else symb))
					)))
				  )
			     (debug "gcc_tree_code:macro2" " sloc=" sloc "; fixed xmatfill=" e)
			     e
			     )
			   )
			  (xcmatcher
			   (let ( (m
				   `(defcmatcher ,treesymb
				      (:tree tr)
				      (:tree ,tupopervar)
				      ,statesymb
				      :doc ,xcmatchdoc
				      ;; match-expander
				      ,xmatexp
				      ;; match-filler
				      ,xmatfill
				      ))
				  )
			     (debug "gcc_tree_code:macro2" " sloc=" sloc "; fixed xcmatcher=" m)
			     m))
			  (xexport `(export_values ,treesymb))
			  )
		       (put_fields xcmatcher :loca_location sloc)
		       (put_fields xexport :loca_location sloc)
		       (debug "gcc_tree_code:macro2" " sloc=" sloc "; " "@fixed xcmatcher=" debug_more xcmatcher
			      "\n.. xexport=" xexport)
		       (let (
			     (rmatch (macroexpand_1 xcmatcher env mexpander modctx))
			     (rexport (macroexpand_1 xexport env mexpander modctx))
			     )
			 (debug "gcc_tree_code:macro2" " rmatch=" rmatch
				"\n.. rexport=" rexport)
			 (return rmatch (tuple rexport))
			 ))
		     )
		    ;; otherwise
		    ( :else
		      (warning_at sloc "MELT should define $1 for tree code of type $2 arity $3"
				  treesymb typcod nargcod)
		      )
		    )
		   )
		 (error_at sloc "unexpected GCC_TREE_CODE for $1" namev)
		 (return ()) ;;  temporarily, happens for non-handled cases
		 )
	       )
      )
  ;; for testing, these are not defined in libmelt-ana-tree.melt
  (gcc_tree_code TREE_BINFO "tree_binfo" tcc_exceptional 0)
  (gcc_tree_code INDIRECT_REF "indirect_ref" tcc_reference 1)
  (gcc_tree_code TRUTH_ORIF_EXPR "truth_orif_expr" tcc_expression 2)
  (gcc_tree_code WIDEN_SUM_EXPR "widen_sum_expr" tcc_binary 2)
  
  #|
  (debug "before loading2 libmelt-treecode")
  (skip_nil (load "_libmelt-treecode.melt"))
  (debug "after loading2 libmelt-treecode")
  |#
  )

;; eof t-treecode.melt