var prg: string; { Исходое выражение }
wrk: string; { Поток накопленных фрагментов }
af: array[#128..#255] of byte; { Адреса фрагментов в потоке }
lastc: char; { Код последнего фрагмента }
lev: string; { Уровни вложенности }
{-------------------------------------------------------------------}
procedure stop(i: integer);
begin writeln('!!! Error ', i, ' !!!'); readln; Halt; end;
{-------------------------------------------------------------------}
{-------------------------------------------------------------------}
function getfrg(c: char): string;
{ Извлекает из потока wrk фрагмент с кодом c }
var i,k: integer;
begin
i:=af[c]; k:=ord(wrk[i]);
getfrg:=Copy(wrk, i+1, k); Delete(wrk, i, k+1);
for c:=#128 to #255 do
if af[c]>i then dec(af[c], k+1);
end;
{-------------------------------------------------------------------}
procedure insfrg(frg: string);
{ Добавляет в конец потока prg фрагмент frg с кодом lastc+1 }
var i: integer;
begin
inc(lastc); af[lastc]:=length(wrk)+1;
wrk:=wrk + frg[0] + frg;
end;
{-------------------------------------------------------------------}
function findop(currlev: integer; op: char): boolean;
{ Находит на текущем уровне первую операцию с приоритетом op ('*' / '+') }
{ Заносит в поток wrk фрагмент выходного кода для этой операции }
{ Удаляет из потока фрагмент, на которые ссылались операнды }
{ Заменяет в исходной prg операцию с операндами на код её фрагмента }
var i: integer; s1,s2: string; c: char;
begin
findop:=false;
for i:=1 to length(prg) do begin
if currlev<>ord(lev[i]) then continue;
c:=prg[i];
if (op='*') and (c<>'*') and (c<>'/') then continue;
if (op='+') and (c<>'+') and (c<>'-') then continue;
if (i=1) or (i=length(prg)) then stop(2);
if prg[i-1] in ['a'..'z', 'A'..'Z'] then s1:=prg[i-1]
else if prg[i-1]>=#128 then s1:=getfrg(prg[i-1])
else stop(2);
if prg[i+1] in ['a'..'z', 'A'..'Z'] then s2:=prg[i+1]
else if prg[i+1]>=#128 then s2:=getfrg(prg[i+1])
else stop(2);
s2:='(' + s1 + ',' + s2 + ')';
case c of
'*': s1:='MUL'; '/': s1:='DIV';
'+': s1:='ADD'; '-': s1:='SUB';
else; end;
insfrg(s1 + s2);
Delete(prg, i, 2); prg[i-1]:=lastc;
Delete(lev, i, 2);
findop:=true; break;
end;
end;
{-------------------------------------------------------------------}
var inp,out: string;
i,k: integer;
maxlev: integer;
begin
inp:='y-(a*s/t-(h+A/f*r/c))*((((b-m))))';
{---------- Определяем уровни вложенности: ----------}
k:=0; maxlev:=0;
prg:=inp; lev:=inp;
for i:=1 to length(prg) do begin
if prg[i]='(' then inc(k);
if prg[i]=')' then dec(k);
if k<0 then stop(1);
if maxlev<k then maxlev:=k;
lev[i]:=char(k);
end;
{---------- Удаляем скобки - они больше не нужны: ----------}
i:=1;
while i<=length(prg) do
if (prg[i]='(') or (prg[i]=')')
then begin Delete(prg, i, 1); Delete(lev, i, 1); end
else inc(i);
{---------- Собственно парсинг: }
lastc:=#127;
wrk:='';
for k:=maxlev downto 0 do begin
while findop(k, '*') do;
while findop(k, '+') do;
end;
if prg<>lastc then stop(3);
out:=getfrg(lastc);
writeln(#177, inp, #177);
writeln(#177, out, #177);
readln;
end.
Просто я не подозревал что в корректной входной строке будут ещё '\r' и '\n'....
Если только вдруг 
Visual Prolog (для компиляции применялась одноименная среда старенькой, кажется, 5-ой, версии).
