Программа неожиданно корректно завершается в процедуре, без halt - Free Pascal

Узнай цену своей работы

Формулировка задачи:

Функция WithList (строка 330) нормально выполняется, однако после ее завершения программа так же завершается. Остальные два пункта нормально работают. Не могу пошагово выполнять ибо FP заглючивает и приходится перезагружаться. С помощью вывода текста выяснила что после третьего пункта в цикле в основной части программы возвращения в этот цикл так и не происходит, после остальных двух пунктов все нормально. Как это возможно и как исправить? input.txt приложила 
uses crt;
 
type
  intfile = file of integer;
  pList = ^List;
  List = record
    data: integer;
    next: pList;
  end;
//------------------------------------------------------------------
procedure Sort(var a: array of integer); overload;
var
  n, i, j, tmp: integer;
begin
  n := length(a);
  for i := n - n mod 2 - 4 downto 0 do
    if i mod 2 = 0 then
      for j := 0 to i do
        if j mod 2 = 0 then
          if a[j]+a[j+1] > a[j+2]+a[j+3] then
          begin
            tmp := a[j];
            a[j] := a[j+2];
            a[j+2] := tmp;
            tmp := a[j+1];
            a[j+1] := a[j+3];
            a[j+3] := tmp;
          end;
end;
//------------------------------------------------------------------
function Delete(var a: array of integer; val: integer): boolean; overload;
var
  n, i, j: integer;
begin
  n := length(a);
  for i := 0 to n-2 do
    if i mod 2 = 0 then
      if a[i]+a[i+1] = val then
      begin
        for j := i to n-3 do
          a[j] := a[j+2];
        Delete := true;
        exit;
      end;
  Delete := false;
end;
//------------------------------------------------------------------
procedure Print(a: array of integer); overload;
var
  i: integer;
begin
  for i := 0 to length(a)-1 do
    write(a[i], ' ');
  writeln;
end;
//------------------------------------------------------------------
procedure WithArray(var f: text);
var
  a: array of integer;
  n, i, m: integer;
begin
  reset(f);
  read(f, n);
  setlength(a, n);
  for i := 0 to n-1 do
    read(f, a[i]);
  close(f);
  write('Ishodnyi massiv: ');
  Print(a);
  Sort(a);
  write('Posle sortirovki: ');
  Print(a);
  write('Vvedite summu dlea udalenia: ');
  readln(m);
  if Delete(a, m) then
  begin
    setlength(a, n-2);
    write('Posle udalenia: ');
    Print(a);
  end
  else
    writeln('Para s ukazannoi summoi ne naidena!');
  readkey;
end;
//------------------------------------------------------------------
procedure TextToTypeFile(var f1: text; var f2: intfile);
var
  n, i, cur: integer;
begin
  rewrite(f2);
  read(f1, n);
  for i := 1 to n do
  begin
    read(f1, cur);
    write(f2, cur);
  end;
  close(f2);
end;
//------------------------------------------------------------------
procedure Sort(var f: intfile); overload;
var
  cur: array [0..3] of integer;
  changed: boolean;
begin
  changed := true;
  while changed do
  begin
    changed := false;
    reset(f);
    read(f, cur[2], cur[3]);
    while not eof(f) do
    begin
      cur[0] := cur[2];
      cur[1] := cur[3];
      read(f, cur[2]);
      if not eof(f) then
        read(f, cur[3])
      else
        break;
      if cur[0]+cur[1] > cur[2]+cur[3] then
      begin
        seek(f, filepos(f)-4);
        write(f, cur[2], cur[3], cur[0], cur[1]);
        changed := true;
      end;
    end;
  end;
  close(f);
end;
//------------------------------------------------------------------
function Delete(var f: intfile; m: integer): boolean; overload;
var
  cur1, cur2: integer;
  found: boolean;
begin
  reset(f);
  found := false;
  while not eof(f) and not found do
  begin
    read(f, cur1);
    if not eof(f) then
      read(f, cur2)
    else
      break;
    if cur1+cur2 = m then
    begin
      while not eof(f) do
      begin
        read(f, cur1);
        if not eof(f) then
          read(f, cur2)
        else
        begin
          seek(f, filepos(f)-3);
          write(f, cur1);
          break;
        end;
        seek(f, filepos(f)-4);
        write(f, cur1, cur2);
        seek(f, filepos(f)+2);
        if eof(f) then
        begin
          seek(f, filepos(f)-2);
          break;
        end;
      end;
      truncate(f);
      found := true;
    end;
  end;
  close(f);
  Delete := found;
end;
//------------------------------------------------------------------
procedure Print(var f: intfile); overload;
var
  cur: integer;
begin
  reset(f);
  while not eof(f) do
  begin
    read(f, cur);
    write(cur, ' ');
  end;
  writeln;
  close(f);
end;
//------------------------------------------------------------------
procedure WithTypeFile(var f: text);
var
  typef: intfile;
  m: integer;
begin
  assign(typef, 'file_of_integer');
  reset(f);
  TextToTypeFile(f, typef);
  write('Soderjimoe tipizirovannogo faila: ');
  Print(typef);
  write('Posle sortirovki: ');
  Sort(typef);
  Print(typef);
  write('Vvedite summu dlea udalenia: ');
  readln(m);
  if Delete(typef, m) then
  begin
    write('Posle udalenia: ');
    Print(typef);
  end
  else
    writeln('Para s ukazannoi summoi ne naidena!');
  readkey;
end;
//------------------------------------------------------------------
procedure FileToList(var f: text; var first: pList);
var
  n, i: integer;
  newelem, last: pList;
begin
  first := nil;
  last := nil;
  reset(f);
  read(f, n);
  for i := 1 to n do
  begin
    new(newelem);
    read(f, newelem^.data);
    newelem^.next := nil;
    if last <> nil then
      last^.next := newelem
    else
      first := newelem;
    last := newelem;
  end;
  close(f);
end;
//------------------------------------------------------------------
procedure Sort(first: pList); overload;
var
  cur: array [0..3] of pList;
  tmp: integer;
  changed: boolean;
begin
  changed := true;
  while changed do
  begin
    changed := false;
    cur[2] := first;
    if first <> nil then
      cur[3] := first^.next
    else
      cur[3] := nil;
    while (cur[3] <> nil) and (cur[3]^.next <> nil) do
    begin
      cur[0] := cur[2];
      cur[1] := cur[3];
      cur[2] := cur[1]^.next;
      cur[3] := cur[2]^.next;
      if cur[3] = nil then
        break;
      if cur[0]^.data+cur[1]^.data > cur[2]^.data+cur[3]^.data then
      begin
        tmp := cur[0]^.data;
        cur[0]^.data := cur[2]^.data;
        cur[2]^.data := tmp;
        tmp := cur[1]^.data;
        cur[1]^.data := cur[3]^.data;
        cur[3]^.data := tmp;
        changed := true;
      end;
    end;
  end;
end;
//------------------------------------------------------------------
function Delete(var first: pList; m: integer): boolean; overload;
var
  prev, cur1, cur2: pList;
  found: boolean;
begin
  found := false;
  prev := nil;
  cur1 := first;
  if cur1 <> nil then
    cur2 := cur1^.next;
  while not found and (cur1 <> nil) and (cur2 <> nil) do
    if cur1^.data+cur2^.data = m then
    begin
      if prev <> nil then
        prev^.next := cur2^.next
      else
        first := cur2^.next;
      dispose(cur1);
      dispose(cur2);
      found := true;
    end
    else
    begin
      prev := cur2;
      cur1 := cur2^.next;
      if cur1 <> nil then
        cur2 := cur1^.next;
    end;
  Delete := found;
end;
//------------------------------------------------------------------
procedure Clear(var first: pList);
var
  tmp: pList;
begin
  while first <> nil do
  begin
    tmp := first;
    first := first^.next;
    dispose(tmp);
  end;
end;
//------------------------------------------------------------------
procedure Print(first: pList); overload;
var
  cur: pList;
begin
  cur := first;
  while cur <> nil do
  begin
    write(cur^.data, ' ');
    cur := cur^.next;
  end;
  writeln;
end;
//------------------------------------------------------------------
procedure WithList(var f: text);
var
  first: pList;
  m: integer;
begin
  reset(f);
  FileToList(f, first);
  write('Ishodnyi spisok: ');
  Print(first);
  Sort(first);
  write('Posle sortirovki: ');
  Print(first);
  write('Vvedite summu dlea udalenia: ');
  readln(m);
  if Delete(first, m) then
  begin
    write('Posle udalenia: ');
    Print(first);
  end
  else
    writeln('Para s ukazannoi summoi ne naidena!');
  Clear(first);
  writeln('Spisok ochischen');
  close(f);
  readkey;
end;
//------------------------------------------------------------------
function Menu: integer;
var
  choice: integer;
begin
  clrscr;
  writeln('1 - Rabota s massivom');
  writeln('2 - Rabota s tipizirovannym failom');
  writeln('3 - Rabota so spiskom');
  writeln('0 - Vyhod iz programmy');
  write('Vash vybor: ');
  readln(choice);
  writeln;
  Menu := choice;
end;
//------------------------------------------------------------------
 
var
  f: text;
 
begin
  assign(f, 'input.txt');
  while true do
    case Menu of
    0: break;
    1: WithArray(f);
    2: WithTypeFile(f);
    3: WithList(f);
    end;
end.

Решение задачи: «Программа неожиданно корректно завершается в процедуре, без halt»

textual
Листинг программы 
procedure WithList(var f: text);
var
  first: pList;
  m: integer;
begin
  reset(f);
  FileToList(f, first); // в этой процедуре файл f открывается/закрывается
  write('Ishodnyi spisok: ');
  Print(first);
  Sort(first);
  write('Posle sortirovki: ');
  Print(first);
  write('Vvedite summu dlea udalenia: ');
  readln(m);
  if Delete(first, m) then
  begin
    write('Posle udalenia: ');
    Print(first);
  end
  else
    writeln('Para s ukazannoi summoi ne naidena!');
  Clear(first);
  writeln('Spisok ochischen');
  close(f); // Но файл УЖЕ закрыт, не нужно перезакрывать его, чревато ошибками, ты видела какими :)
  readkey;
end;

Объяснение кода листинга программы

  1. Объявлены следующие переменные:
    • first: pList;
    • m: integer;
  2. Вызов функции reset(f), которая открывает файл f для чтения.
  3. Вызов функции FileToList(f, first), которая заполняет список first содержимым файла f.
  4. Вывод сообщения Ishodnyi spisok: и вызов функции Print(first), которая выводит список first на экран.
  5. Вызов функции Sort(first), которая сортирует список first по возрастанию.
  6. Вывод сообщения Posle sortirovki: и вызов функции Print(first), которая выводит отсортированный список на экран.
  7. Вывод сообщения Vvedite summu dlia udalenia: и вызов функции readln(m), которая считывает с клавиатуры целое число и сохраняет его в переменной m.
  8. Проверка условия Delete(first, m) (удаление элемента из списка по индексу).
    • Если условие истинно, то выполняются действия:
    • Вывод сообщения Posle udalenia: и вызов функции Print(first), которая выводит список first на экран.
    • Закрытие списка first с помощью функции Clear(first).
    • Вывод сообщения Spisok ochischen и закрытие файла f с помощью функции close(f).
    • Ожидание нажатия клавиши с помощью функции readkey.
    • Если условие ложно, то выводится сообщение Para s ukazannoi summoi ne naidena!.
  9. Файл УЖЕ закрыт, не нужно перезакрывать его, чревато ошибками.

ИИ поможет Вам:

  • решить любую задачу по программированию
  • объяснить код
  • расставить комментарии в коде
  • и т.д
Попробуйте бесплатно

Оцени полезность:

10   голосов , оценка 4.1 из 5
Похожие ответы