Проблема с удалением элемента списка из памяти Опции

[mr.]

Программа, создающая список типа "стэк", создающая элементы списка равные по модулю отрицательным после них, а затем удаляющая сами отрицательные элементы. Проблема состоит в том что процедура DeleteNeg, "стопорится", если указываешь ей удалять элемент списка из памяти Dispose(Del). Если закомментарить эту строчку, то программа все выполняет без проблем, но отрицательные элементы получается удаляются только логически, а память не освобождается. как предотвратить это. А то предстоит еще делать более сложные вещи со списками=)

P.S. думаю что тема-вопрос про такого рода задания уже была, но меня интересует именно почему удаление из памяти не делается. Буду благодарен если мне кто нибудь поможет найти причину)

Вот код программы

Код

program hw_1;
uses crt;
type
     PItem=^TItem;
     TItem=record
     Data:integer;
     Prev:PItem;
     end;
var
    P:PItem;
    Head:PItem;
    fl:text;

procedure CreateSame;
var Pnew:PItem;
    Curr:PItem;
begin
Curr:=Head;
while Curr<>nil do begin
if Curr^.Data<0 then begin
   new(Pnew);
   Pnew^.Prev:=Curr^.Prev;
   Pnew^.Data:=Abs(Curr^.Data);
   Curr^.Prev:=Pnew;
end;
Curr:=Curr^.Prev;
end;
end;

procedure DeleteNeg;
var
Del:PItem;
Save:PItem;
Curr:PItem;
begin
Curr:=Head;
While (Head^.Data<0) and (Head<>nil) do
begin
Curr:=Head;
Head:=Head^.Prev;
Dispose(Curr);
end;
Save:=Head;
Curr:=Head^.Prev;
while Curr<>nil do begin
if Curr^.Data>0 then
Save:=Curr
else
begin
Save^.Prev:=Curr^.Prev;
Del:=Curr;
{Dispose(Del);}
end;
Curr:=Curr^.Prev;
end;
end;

procedure ShowList;
var Curr:PItem;
begin
TextColor(15);
Curr:=Head;
while Curr<>nil do begin
write(Curr^.Data,'  ');
Curr:=Curr^.Prev;
end;
end;

procedure CheckList;
begin
       CreateSame;
       writeln;
       Textcolor(5);
       writeln('‘®§¤ ­л а ў­лҐ Ї® ¬®¤г«о ®ваЁж вҐ«м­л¬');
       ShowList;
       DeleteNeg;
end;

procedure MakeList;
  begin
    Head:=nil;
    While not (EOF(fl)) do begin
    new(P);
    readln(fl,P^.Data);
    if Head<>nil then P^.Prev:=Head
    else P^.Prev:=nil;
    Head:=P;
    end;{while}
  end;


Begin
ClrScr;
   Assign(fl,'HW_1.txt');
    {$I-}
    reset(fl);
    {$I+}
    if IOResult=0 then begin
    MakeList;
    TextColor(5);
    writeln('?б室­л© бЇЁб®Є');
    ShowList;
    CheckList;
    end
    else writeln('ЋиЁЎЄ  ®вЄалвЁп д ©« ');
writeln;
TextColor(5);
writeln('ЏаҐ®Ўа §®ў ­­л© бЇЁб®Є');
ShowList;
readln;
readln;
end.

вот еще прикрепил файл с этой программой.

Сообщение отредактировано: mr. - 24.03.2006 18:33