diff options
| -rw-r--r-- | gcc/ChangeLog.MELT | 20 | ||||
| -rw-r--r-- | gcc/melt-runtime.h | 2 | ||||
| -rw-r--r-- | gcc/melt/warmelt-base.melt | 71 | ||||
| -rw-r--r-- | gcc/melt/warmelt-first.melt | 12 | ||||
| -rw-r--r-- | gcc/melt/warmelt-normatch.melt | 4 |
5 files changed, 81 insertions, 28 deletions
diff --git a/gcc/ChangeLog.MELT b/gcc/ChangeLog.MELT index 3fa07848c67..0f6d7287fe5 100644 --- a/gcc/ChangeLog.MELT +++ b/gcc/ChangeLog.MELT @@ -1,4 +1,24 @@ +2014-01-18 Basile Starynkevitch <basile@starynkevitch.net> + + * melt-runtime.h: Improve comment regarding melt_assermsg. + + * melt/warmelt-first.melt (register_option): Inform that it is + obsolete. To be removed. + (multiple_sort): Add a comment that it should be replaced by a + function from warmelt-base.melt + + * melt/warmelt-base.melt: Add thru cheader an #include of <vector> + and <algorithm>, and a global declaration of + Melt_Sort_Compare_Index class in the generated code. + (multiple_sort_new): New function which should replace the old + multiple_sort primitive. Uses std::stable_sort with + Melt_Sort_Compare_Index. See + http://stackoverflow.com/q/21201685/841108 for details. + + * melt/warmelt-normatch.melt: Remove register_option for + alternate_match. + 2014-01-17 Basile Starynkevitch <basile@starynkevitch.net> * melt/generated/*: Regenerate all. diff --git a/gcc/melt-runtime.h b/gcc/melt-runtime.h index fc5158a605a..ce2b9f39a70 100644 --- a/gcc/melt-runtime.h +++ b/gcc/melt-runtime.h @@ -2658,7 +2658,7 @@ melt_ptr_t meltgc_read_from_val(melt_ptr_t strv_p, melt_ptr_t locnam_p); /* called from c-common.c in handle_melt_attribute */ void melt_handle_melt_attribute(tree decl, tree name, const char* attrstr, location_t loch); -/* Use melt_assert(MESSAGE,EXPR) to test invariants. The MESSAGE +/* Use melt_assertmsg(MESSAGE,EXPR) to test invariants. The MESSAGE should be a constant string displayed when asserted EXPR is false */ void diff --git a/gcc/melt/warmelt-base.melt b/gcc/melt/warmelt-base.melt index e1b0dd26781..7ffe9c8f99c 100644 --- a/gcc/melt/warmelt-base.melt +++ b/gcc/melt/warmelt-base.melt @@ -41,7 +41,8 @@ ;; Our multiple_sort needs std::sort used with hook_sort_compare (cheader #{ -/* C++ standard header for multiple_sort */ +/* C++ standard headers for multiple_sort */ +#include <vector> #include <algorithm> }#) @@ -3277,10 +3278,32 @@ typedef struct melthook_st *melthook_ptr_t; ) ) ;end hook_sort_compare +(cheader + #{ + /* A compare structure used in multiple_sort for std::stable_sort; + it has to be a compilation-unit global type; + it cannot be a struct inside multiple_sort; + see http://stackoverflow.com/q/21201685/841108 + and ISO/IEC 14882 C++03 standard section 14.3.1 + */ + class Melt_Sort_Compare_Index { + struct meltmultiple_st** melttup_ad; + melt_ptr_t* meltcmp_ad; + public: + Melt_Sort_Compare_Index (struct meltmultiple_st**tup_ad, melt_ptr_t* cmp_ad) + : melttup_ad(tup_ad), meltcmp_ad(cmp_ad) {}; + ~Melt_Sort_Compare_Index() { meltcmp_ad=NULL; melttup_ad=NULL; }; + bool operator () (int meltleftix, int meltrightix) { + return (bool) + melthookproc_HOOK_SORT_COMPARE((*melttup_ad)->tabval[meltleftix], + (*melttup_ad)->tabval[meltrightix], + *meltcmp_ad); + }; + }; /* end class Melt_Sort_Compare_Index */ + }#) -#| ;;;;;;;; our "re-entrant" tuple sorter using std::stable_sort -(defun multiple_sort (mul cmp discrm) +(defun multiple_sort_new (mul cmp discrm) :doc #{Returns a sorted tuple from the tuple $MUL, the compare function $CMP, see $HOOK_SORT_COMPARE for details about it, using the optional tuple discriminant $DISCRM (using $DISCR_MULTIPLE if null). @@ -3301,32 +3324,38 @@ typedef struct melthook_st *melthook_ptr_t; #{ /* multiple_sort $CHECKMAGIC_CHK */ (((meltobject_ptr_t)($DISCRIM))->meltobj_magic == MELTOBMAG_MULTIPLE) }#) (return ())) - (let ( (res (clone_with_discriminant mul discrm)) + (let ( (:long tuplen (multiple_length mul)) + (res (make_multiple discrm tuplen)) (:long reslen (multiple_length res)) ) (code_chunk sortres_chk #{ /* multiple_sort $SORTRES_CHK start */ - struct Melt_Sort_Compare_$SORTRES_CHK { - bool operator () (melt_ptr_t meltleft_$SORTRES_CHK, melt_ptr_t meltright_$SORTRES_CHK) { - return (bool) - $(hook_sort_compare - $(expr_chunk left_chk :value #{ /* multiple_sort $LEFT_CHK */ meltleft_$SORTRES_CHK}#) - $(expr_chunk right_chk :value #{ /* multiple_sort $RIGHT_CHK */ meltright_$SORTRES_CHK}#) - cmp); - }; - }; /* end struct Melt_Sort_Compare_$SORTRES_CHK */ - long meltsortlen_$SORTRES_CHK = $RESLEN; - struct Melt_Sort_Compare_$SORTRES_CHK meltsorter_$SORTRES_CHK; - std::stable_sort (((meltmultiple_st*)$RES)->tabval, - ((meltmultiple_st*)$RES)->tabval+meltsortlen_$SORTRES_CHK, - meltsorter_$SORTRES_CHK); - meltgc_touch ($RES); // the touch is often useless but won't harm + melt_assertmsg ("check that MUL is multiple when starting multiple_sort", + melt_magic_discr ($MUL) == MELTOBMAG_MULTIPLE); + if ($RESLEN >= (long)INT_MAX/2) + melt_fatal_error("too big sized %ld tuple to sort", $RESLEN); + Melt_Sort_Compare_Index meltixsorter_$SORTRES_CHK ((meltmultiple_st**)(&($MUL)), &($CMP)); + std::vector<int> meltixvect_$SORTRES_CHK; + meltixvect_$SORTRES_CHK.resize($RESLEN); + for (long meltix=0; meltix<$RESLEN; meltix++) + meltixvect_$SORTRES_CHK[meltix] = meltix; + std::stable_sort (meltixvect_$SORTRES_CHK.begin(), + meltixvect_$SORTRES_CHK.end(), + meltixsorter_$SORTRES_CHK); + melt_assertmsg ("check that RES is multiple in multiple_sort", melt_magic_discr ($RES) == MELTOBMAG_MULTIPLE); + melt_assertmsg ("check that MUL is multiple in multiple_sort", melt_magic_discr ($MUL) == MELTOBMAG_MULTIPLE); + for (long meltix=0; meltix<$RESLEN; meltix++) { + int sortix_$SORTRES_CHK = meltixvect_$SORTRES_CHK[meltix]; + melt_assertmsg ("check index in multiple_sort", sortix_$SORTRES_CHK>=0 && (long)sortix_$SORTRES_CHK < $RESLEN); + ((meltmultiple_st*)($RES))->tabval[meltix] = ((meltmultiple_st*)($MUL))->tabval[sortix_$SORTRES_CHK]; + }; + meltgc_touch ($RES); /* multiple_sort $SORTRES_CHK end */ }#) (assert_msg "check res" (is_multiple res) res) (return res))) -|# + ;;;;; (export_values @@ -3494,7 +3523,7 @@ typedef struct melthook_st *melthook_ptr_t; multiple_backward_every multiple_every multiple_every_both - ;multiple_sort + multiple_sort_new negi nonzero_hash noti diff --git a/gcc/melt/warmelt-first.melt b/gcc/melt/warmelt-first.melt index 94cd5d0ed1e..49819c5eead 100644 --- a/gcc/melt/warmelt-first.melt +++ b/gcc/melt/warmelt-first.melt @@ -1485,6 +1485,7 @@ an integer $I if $I is greater than $N.}# :doc #{Put into tuple $MUL at rank $N the component $V. Avoid circularities!}# #{meltgc_multiple_put_nth((melt_ptr_t)($mul), ($n), (melt_ptr_t)($V))}#) ;; sort a multiple, the compare function should return a boxed integer +;; should be replaced by a function in warmelt-base.melt (defprimitive multiple_sort (mul cmp discrm) :value :doc #{Gives the sorted tuple from tuple $MUL using compare function $CMP (returning a boxed integer) and discriminant $DISCRM.}# @@ -3143,8 +3144,15 @@ Keyword is :cstring.}# (defun register_option (optsymb opthelp optfun) - (void) - ) + (let ( (symnam (get_field :named_name optsymb)) + ) + (code_chunk fail_register_option_chk + #{ /* register_option $FAIL_REGISTER_OPTION_CHK */ + inform (UNKNOWN_LOCATION, + "register_option of %s is obsolete", + melt_string_str($SYMNAM)) ; + }#) + )) diff --git a/gcc/melt/warmelt-normatch.melt b/gcc/melt/warmelt-normatch.melt index 15a90e7860c..4d9a6e20251 100644 --- a/gcc/melt/warmelt-normatch.melt +++ b/gcc/melt/warmelt-normatch.melt @@ -6905,10 +6905,6 @@ normalized expression.}# (install_method class_source_match normal_exp normexp_matchalt) (install_method class_source_matchalt normal_exp normexp_matchalt) ) -(register_option - 'alternate_match - '"exchange alternate pattern-matching implementation" - alternate_match_optset) |