diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ChangeLog.MELT | 4 | ||||
| -rw-r--r-- | gcc/melt/warmelt-normatch.melt | 50 | ||||
| -rw-r--r-- | gcc/testsuite/melt/tmatch-6.melt | 6 |
3 files changed, 51 insertions, 9 deletions
diff --git a/gcc/ChangeLog.MELT b/gcc/ChangeLog.MELT index c9cfd6bc30d..38b7e660bd6 100644 --- a/gcc/ChangeLog.MELT +++ b/gcc/ChangeLog.MELT @@ -1,3 +1,7 @@ +2010-09-29 Basile Starynkevitch <basile@starynkevitch.net> + * testsuite/melt/tmatch-6.melt: updated comment. + * melt/warmelt-normatch.melt: completed normstep_msuccwhenflag. + 2010-09-27 Basile Starynkevitch <basile@starynkevitch.net> * testsuite/melt/tmatch-7.melt: has a complex match input argument to test its normalization. diff --git a/gcc/melt/warmelt-normatch.melt b/gcc/melt/warmelt-normatch.melt index f52d9f99ade..5ac940aebac 100644 --- a/gcc/melt/warmelt-normatch.melt +++ b/gcc/melt/warmelt-normatch.melt @@ -47,7 +47,7 @@ occurrences. $PCTN_TESTS is the list of normal testers. $PCTN_VARHANDERS is a list of pattern variable handler when scanning variables.}# :fields (pctn_normctxt ;the class_normalization_context - pctn_src ;the source match expressioon + pctn_src ;the source match expression pctn_env ;the current environment ;; mapping symbols to patternvars pctn_mapatvar ;objmap of patternvars @@ -4995,9 +4995,10 @@ normalized expression.}# ))) (install_method class_match_step_test_variable normalize_step normstep_mtestvar) -;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;; + (defun normstep_msuccwhenflag (step nmctxt sloc) (debug_msg step "normstep_msuccwhenflag step") (assert_msg "check step" (is_a step class_match_step_success_when_flag)) @@ -5006,25 +5007,61 @@ normalized expression.}# (matflag (unsafe_get_field :mstep_flag step)) (matthen (unsafe_get_field :mstep_then step)) (matvarocc (unsafe_get_field :mstepsuccess_varocc step)) + (nmatresloc (get_field :matnorx_resloc nmctxt)) (mbinds (unsafe_get_field :mstepsuccess_binds step)) (matbody (unsafe_get_field :mstepsuccess_body step)) ) (debug_msg matflag "normstep_msuccwhenflag mflag") - (debug_msg matvarocc "normstep_msuccwhenflag mvarocc") + (debug_msg matvarocc "normstep_msuccwhenflag matvarocc") (debug_msg mbinds "normstep_msuccwhenflag mbinds") - (debug_msg matbody "normstep_msuccwhenflag mbody") + (debug_msg matbody "normstep_msuccwhenflag matbody") (debug_msg matthen "normstep_msuccwhenflag mthen") + (debug_msg nmatresloc "normstep_msuccwhenflag nmatresloc") (let ( (nthen (altmatch_normalize_step matthen nmctxt)) (nflag (altmatch_normalize_flag matflag nmctxt)) (matctx (unsafe_get_field :matnorx_matchctxt nmctxt)) + (jumpthen (instance class_nrep_match_jump + :nmjmp_label nthen)) + (njthen (complete_normstep_if_last step jumpthen nmctxt)) + (:long matbodylen (multiple_length matbody)) + (lastmatbody (multiple_nth matbody -1)) + (nsetqres (instance class_nrep_setq + :nrep_loc nsloc + :nstq_var nmatresloc + :nstq_exp lastmatbody + )) + (newmatbody (make_multiple discr_multiple (+i matbodylen 2))) ) + ;; we build a newmatbody fdrom the matbody and add the setting + ;; of the match result and the jump + (foreach_in_multiple + (matbody) + (curmatbody :long bix) + (multiple_put_nth newmatbody bix curmatbody) + ) + (multiple_put_nth newmatbody -2 nsetqres) + (multiple_put_nth newmatbody -1 njthen) (debug_msg nthen "normstep_msuccwhenflag nthen") + (debug_msg njthen "normstep_msuccwhenflag njthen") (debug_msg nflag "normstep_msuccwhenflag nflag") - (assert_msg "@$@unimplemented normstep_msuccwhenflag") - ))) + (debug_msg newmatbody "normstep_msuccwhenflag newmatbody") + (let ( + (nifsucc (instance class_nrep_if + :nrep_loc nsloc + :nif_test nflag + :nif_then (wrap_normal_letseq newmatbody mbinds nsloc) + :nexpr_ctyp ctype_void + :nif_else ())) + + ) + (debug_msg nifsucc "normstep_msuccwhenflag final nifsucc") + (return nifsucc) + )))) (install_method class_match_step_success_when_flag normalize_step normstep_msuccwhenflag) + + ;;;;;;;;;;;;;;;; (defun normstep_mtestmatcher (step nmctxt sloc) (debug_msg step "normstep_mtestmatcher step") @@ -5401,6 +5438,7 @@ nmctxt) (assert_msg "check env" (is_a env class_environment)) (assert_msg "check nctxt" (is_a ncx class_normalization_context)) (debug_msg recv "normexp_altmatch recv") + (shortbacktrace_dbg "normexp_altmatch start" 20) (let ( (sloc (or (unsafe_get_field :loca_location recv) psloc)) (smatsx (unsafe_get_field :smat_matchedx recv)) (scases (unsafe_get_field :smat_cases recv)) diff --git a/gcc/testsuite/melt/tmatch-6.melt b/gcc/testsuite/melt/tmatch-6.melt index 325c5d86be1..10934ad3b5b 100644 --- a/gcc/testsuite/melt/tmatch-6.melt +++ b/gcc/testsuite/melt/tmatch-6.melt @@ -2,7 +2,7 @@ ;; file tmatch-6.melt #| run in buildir/gcc - ./cc1 -fmelt=runfile -fmelt-module-path=. -fmelt-source-path=.:$GCCMELTSOURCE/gcc/melt \ + ./cc1 -fmelt-mode=runfile -fmelt-module-path=. -fmelt-source-path=.:$GCCMELTSOURCE/gcc/melt \ -fmelt-tempdir=/tmp -fmelt-init=@warmelt2 \ -fmelt-option=match_graphic=/tmp/melt6graph,alternate_match \ -fmelt-arg=$GCCMELTSOURCE/gcc/testsuite/melt/tmatch-6.melt \ @@ -14,7 +14,7 @@ (match symb ( ?(instance class_symbol :named_name ?synam) - synam))) + (if (is_string synam) synam)))) #| (debug_msg (testnameofsymbol 'asymbol) "testnameofsymbol asymbol") @@ -130,4 +130,4 @@ -;;; eof tmatch-6.melt
\ No newline at end of file +;;; eof tmatch-6.melt |