Recursion depth exceeded in pattern matching with attribute Flat

I find Flat hard to work with. Despite seeing it in use numerous times I'm never quite sure what it will do until I try it, so maybe I'm not the person to answer your question. Nevertheless I shall try.

Consider this related, reduced example:

Attributes[foo] = {Flat, OneIdentity};
foo[a_] := "inert" /; Print @ HoldForm[a]

foo[X, Y];

foo[X,Y]

X

Y

Critically the entire expression foo[X, Y] is substituted for the pattern a_ in one of the match attempts. This leads to infinite recursion.

One way to get around this is to prevent evaluation of that expression, which is what I used HoldForm for above. Applied to your original function:

ClearAll[Mult]
Attributes[Mult] = {Flat, OneIdentity};
Mult[A___, a_, B___] := a Mult[A, B] /; NumberQ[Unevaluated @ a]

Mult[X, Y]

Mult[3, x, 7, y, z]

Mult[X, Y]

21 Mult[x, y, z]

This is basically a duplicate of question (5067). You can use my answer to that question to resolve your issue:

ClearAll[Mult]
SetAttributes[Mult, {Flat, OneIdentity}];
Verbatim[Mult][A___, a_, B___] := a Mult[A,B] /; NumberQ[a]

Then:

Mult[X, Y]
Mult[3, X, 7, Y, Z]

Mult[X, Y]

21 Mult[X, Y, Z]

No recursion errors.

Comparison

Using Verbatim should be much quicker than the accepted answer, because those patterns where a gets matched with a Mult object should never happen. The accepted answer (using Mult2):

ClearAll[Mult2]
Attributes[Mult2] = {Flat, OneIdentity};
Mult2[A___, a_, B___] := a Mult2[A,B] /; NumberQ[Unevaluated@a]

And a comparison:

SeedRandom[1]
r = RandomChoice[Join[Alphabet[], Range[10]], 30];

r1 = Mult @@ r; //AbsoluteTiming
r2 = Mult2 @@ r; //AbsoluteTiming

ReplaceAll[Mult->List] @ r1 === ReplaceAll[Mult2->List] @ r2

{0.000206, Null}

{0.025536, Null}

True