diff options
| -rw-r--r-- | gcc/ChangeLog.MELT | 7 | ||||
| -rw-r--r-- | gcc/melt/warmelt-macro.melt | 18 | ||||
| -rw-r--r-- | gcc/testsuite/melt/t-treecode.melt | 506 |
3 files changed, 278 insertions, 253 deletions
diff --git a/gcc/ChangeLog.MELT b/gcc/ChangeLog.MELT index 15977e6a56a..5e5dec204df 100644 --- a/gcc/ChangeLog.MELT +++ b/gcc/ChangeLog.MELT @@ -1,4 +1,11 @@ +2014-10-27 Basile Starynkevitch <basile@starynkevitch.net> + * melt/warmelt-macro.melt (mexpand_let): For :macro bindings, stop + the expansion on error before and after + melt_delayed_macro_expander. + + * testsuite/melt/t-treecode.melt: Simplified, but still don't work. + 2014-10-25 Basile Starynkevitch <basile@starynkevitch.net> * testsuite/melt/t-treecode.melt: Simplified to use a few treecodes but still don't work! diff --git a/gcc/melt/warmelt-macro.melt b/gcc/melt/warmelt-macro.melt index c18e48976c9..fc76f9dd6b0 100644 --- a/gcc/melt/warmelt-macro.melt +++ b/gcc/melt/warmelt-macro.melt @@ -7185,15 +7185,25 @@ applications of @code{/i} primitives.}# "\n.. mexpanderm=" debug_less mexpanderm "\n.. macbind=" macbind) (shortbacktrace_dbg "mexpand_let:mexpanser" 25) + (when (>i (melt_error_counter) 0) + (debug "mexpand_let:mexpanser" " loc=" loc " errored") + (error_at loc "MELT will not expand LET :macro $1 with #$2 errors" + macsymb (melt_error_counter)) + (return ())) (debug "mexpand_let:mexpanser before melt_delayed_macro_expander" " maclist=" maclist "\n.. macbind=" macbind) (melt_delayed_macro_expander macbind maclist envm mexpanderm modctx) - (debug "mexpand_let:mexpanser after melt_delayed_macro_expander" + (debug "mexpand_let:mexpanser" " loc=" loc " after melt_delayed_macro_expander" " maclist=" maclist "\n.. macbind=" macbind) + (when (>i (melt_error_counter) 0) + (debug "mexpand_let:mexpanser" " loc=" loc " delayerrored") + (error_at loc "MELT will not expand LET :macro $1 with #$2 errors after delayed expansion" + macsymb (melt_error_counter)) + (return ())) (let ( (mclos (get_field :mbind_expanser macbind)) (locm (get_field :loca_location sexprm)) ) - (debug "mexpand_let:mexpanser" + (debug "mexpand_let:mexpanser" " afterdelay" " loc=" loc " locm=" locm "\n.. mclos=" mclos "\n.. mexpanser=" mexpanser @@ -7202,6 +7212,10 @@ applications of @code{/i} primitives.}# (error_at locm "failed to macro-expand LET :macro $1" macsymb) (warning_at loc "failed to expand LET :macro $1 defined here" macsymb) (return)) + (debug "mexpand_let:mexpanser" + " beforemulticall" + " loc=" loc " locm=" locm + " mclos=" mclos " sexprm=" sexprm) (multicall (expmac othermac) (mclos sexprm envm mexpanderm modctxm) diff --git a/gcc/testsuite/melt/t-treecode.melt b/gcc/testsuite/melt/t-treecode.melt index 09c7ac04829..af442cbe4d8 100644 --- a/gcc/testsuite/melt/t-treecode.melt +++ b/gcc/testsuite/melt/t-treecode.melt @@ -39,108 +39,38 @@ gcc -fplugin=melt -fplugin-arg-melt-mode=runfile @meltbuild-common.args \ (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 - )) + (: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) + (debug "gcc_tree_code:macro2" "; exceptional namev=" namev) (let ( (xcmatchdoc @@ -148,24 +78,24 @@ gcc -fplugin=melt -fplugin-arg-melt-mode=runfile @meltbuild-common.args \ ( (d (substitute_sexpr - '#{Generated simple $TYPCOD $TREESYMB cmatcher.}# + '#{Generated tcc_exceptional $TREESYMB cmatcher.}# (lambda (symb) - (debug "gcc_tree_code:macro2-lambdasubsttypcod symb=" symb) - (if (== symb 'typcod) - (get_field :named_name typcod) + (debug "gcc_tree_code:macro2-lambdasubstdoc symb=" symb) + (if (== symb 'treesymb) + (get_field :named_name treesymb) symb)))) ) - (debug "gcc_tree_code:macro2"" sloc=" sloc "; constdecl xcmatchdoc=" d) + (debug "gcc_tree_code:macro2" "; sloc=" sloc " exceptional xcmatchdoc=" d) d)) (xmatexp (let ( (e (substitute_sexpr - '#{ /* generated simple $TREESYMB tester ? */ + '#{ /* generated exceptional $TREESYMB tester ? */ $TR && TREE_CODE($TR) == $NAMECOD }# (lambda (symb) - (debug "gcc_tree_code:macro2-lambdasubsttypcod symb=" symb) + (debug "gcc_tree_code:macro2-lambdasubstexp symb=" symb) (cond ( (== symb 'treesymb) (clone_with_discriminant (get_field :named_name treesymb) discr_verbatim_string) @@ -177,7 +107,7 @@ gcc -fplugin=melt -fplugin-arg-melt-mode=runfile @meltbuild-common.args \ symb))) )) ) - (debug "gcc_tree_code:macro2"" sloc=" sloc "; constdecl xmatexp=" e) + (debug "gcc_tree_code:macro2" "; sloc=" sloc " exceptional xmatexp=" e) e)) (xcmatcher `(defcmatcher ,treesymb @@ -192,163 +122,237 @@ gcc -fplugin=melt -fplugin-arg-melt-mode=runfile @meltbuild-common.args \ ) (put_fields xcmatcher :loca_location sloc) (put_fields xexport :loca_location sloc) - (debug "gcc_tree_code:macro2" " sloc=" sloc "; constdecl xcmatcher=" debug_more xcmatcher + (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 "; rmatch=" rmatch + (debug "gcc_tree_code:macro2" "; sloc=" sloc " exceptional 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))) + ;; tcc_constant & tcc_declaration, without sub-trees + ( + (or (== typcod 'tcc_constant) + (== typcod 'tcc_declaration) + ) + (debug "gcc_tree_code:macro2" "; simple namev=" namev) + (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 )) - ) - (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)) + (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) + ) + (debug "gcc_tree_code:macro2" "; fixed namev=" namev) + (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 + ) ) - (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) - ) + (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 + (debug "gcc_tree_code:macro2 bad namev=" namev) + (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 - ) - ) + ) + (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) + ;;! (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") |