freepascal.ru

Люди помогите с кодом. При компиляции в FPC, программа завершает работу с ошибкой Runtime error 216, при компиляции кода в BP7 программа работает без ошибок. Ошибка в стр.158 процедуре pr_DirectFusion.

Код: Выделить всё

program lab3;

uses Crt;
const
chis=['1'..'2'];{Массив для работы меню}

type
  PInf = ^TInf;
  TInf = record {Запись для элемента очереди}
    num:Integer; {Число }
    next:PInf; {Указатель на следующий элемент очереди}
  end;

var
  c,m:Longint; {Количество операций сравнения и пересылок}
  key:char; {Переменная для работы меню}
  keys,kn:integer;
  ftext:text; {Переменная для работы с текстовым файлом}
  txt_filename:string[9]; {Переменная для определения имени файла}


function IsQueueEmpty(qHead, qTail:PInf):Boolean;{Функция проверки очереди на пустоту}
begin
  IsQueueEmpty:=qHead=nil;
end;



procedure SetQueueNext(var qHead, qTail:PInf; next:PInf);{Процедура устанавливает следующий элемент очереди}
begin
  if IsQueueEmpty(qHead, qTail) then begin
    qHead:=next
    end
  else begin
    qTail^.next:=next;
  end;
  qTail:=next;
end;



procedure AddQueueNext(var qHead, qTail:PInf; num:Integer);{Процедура добавления нового элемента в очередь}
var
  p:PInf;
begin
  New(p);
  p^.num:=num;
  p^.next:=nil;
  SetQueueNext(qHead, qTail, p);
end;



procedure EmptyQueue(var qHead, qTail:PInf);{Процедура очистки очереди}
begin
  qHead:=nil;
  qTail:=nil;
end;



procedure RandomQueue(var qHead, qTail:PInf);{Процедура заполнения очереди случайными числами от 0 до 99}
var
  i:Integer;
begin
  Randomize;
  for i:=1 to kn do
    AddQueueNext(qHead, qTail, Random(100));
end;



procedure pr_DirectFusion(var qHead, qTail:PInf); {Процедура сортировки очереди методом прямого слияния}
var
  aHead:array[0..1] of PInf; {Указатели на начала рабочих очередей }
  aTail:array[0..1] of PInf; {Указатели на концы рабочих очередей }
  cHead:array[0..1] of PInf; {Указатели на начала очередей для слияния }
  cTail:array[0..1] of PInf; {Указатели на концы очередей для слияния }
  qr:array[0..1] of Integer; {Размеры серий для рабочих очередей }
  i,k,n,p:Integer;
  p1:PInf;


begin
  c:=0;
  m:=0;


  for i:=0 to 1 do
    EmptyQueue(aHead[i], aTail[i]);
  n:=0;
  k:=0;
  p1:=qHead;

  while p1<>nil do begin {Делаем расщепление очереди на 2 очереди}
    SetQueueNext(aHead[k], aTail[k], p1);
    Inc(m);
    Inc(n);
    k:=1-k; {Меняем очередь на другую }
    p1:=p1^.next;
  end;

  for k:=0 to 1 do
    aTail[k]^.next:= nil;
  p:=1; {Начинаем основной алгоритм сортировки }
 

  while p<n do begin
    for k:=0 to 1 do
      EmptyQueue(cHead[k], cTail[k]);
    i:=0;

    {Пока в рабочих очередях есть элементы }
    while (aHead[0]<>nil) or (aHead[1]<>nil) do begin
      for k:=0 to 1 do begin
        qr[k]:=0;
        if aHead[k] <> nil then
          qr[k]:=p;
      end;
      {Реализовываем алгоритм слияния }

      while (qr[0] > 0) and (qr[1] > 0) do begin
        case aHead[0]^.num < aHead[1]^.num of
          True:k:=0;
          False:k:=1;
        end;

        Inc(c);
        SetQueueNext(cHead[i], cTail[i], aHead[k]);
        Inc(m);


        {Перемещаем указатель начала рабочей очереди вперед }
        aHead[k]:=aHead[k]^.next;
        if aHead[k] <> nil then
          Dec(qr[k])
        else
          qr[k]:=0;
      end;

      k:=-1;
      if qr[0] > 0 then {Если в рабочей очереди 0 еще остались элементы }
        k:=0
      else if qr[1] > 0 then {Если в рабочей очереди 0 еще остались элементы }
        k:=1;
      if k in [0,1] then
        while (qr[k]>0) and (aHead[k]<>nil) do begin
          SetQueueNext(cHead[i],cTail[i],aHead[k]);
          Inc(m);
          aHead[k]:=aHead[k]^.next;
          Dec(qr[k]);
        end;
      i:=1-i;
    end;
   

    for k:=0 to 1 do begin
      cTail[k]^.next:=nil;
    end;
   

    for k:=0 to 1 do begin
      aHead[k]:=cHead[k]; {Получаем новые рабочие очереди }
    end;
    p:=2*p; {Увеличиваем размер серии }
  end;
  qHead:=cHead[0];
  qTail:=cTail[0];
end;



{ Возвращает из числа num цифру с номером digitNo, при условии, что
  в числе всего digitsNumber цифр }
function Digit(num, digitsNumber, digitNo: Integer): Integer;
var
  i:Integer;
  s:String;
begin
  Str(num,s);
  while Length(s) < digitsNumber do
    s:='0'+s;
  Digit:= Ord(s[digitNo]) - Ord('0');
end;



procedure ConcatQueues(var q1Head, q1Tail: PInf; q2Head, q2Tail: PInf);{Процедура Объединения двух очередей}
begin
  if IsQueueEmpty(q2Head, q2Tail) then
    Exit;
  if IsQueueEmpty(q1Head, q1Tail) then begin
    q1Head := q2Head;
    q1Tail := q2Tail;
  end
  else begin
    q1Tail^.next := q2Head;
    q1Tail := q2Tail;
  end;
end;



procedure pr_DigitalSorting(var qHead, qTail:PInf);{Процедура цифровой сортировки очереди}
const
  l= 2; {Количество байт для сравнения}
  mm= 10; {Количество очередей}
var
  qmHead: array[0..mm - 1] of PInf; {Головы очередей}
  qmTail: array[0..mm - 1] of PInf; {Хвосты очередей}
  i,d,j:Integer;
  p,pTmp:PInf;

begin
  c:=0;
  m:=0;
  for j:=l downto 1 do begin
    for i:=0 to mm-1 do {Делаем очереди пустыми}
      EmptyQueue(qmHead[i], qmTail[i]);
    p:=qHead;
    while p<>nil do begin {Заполняем очереди}
      d:=Digit(p^.num, l, j);
      pTmp:=p;
      p:=p^.next;
      SetQueueNext(qmHead[d], qmTail[d], pTmp);
      qmTail[d]^.next:=nil;
      Inc(m);
    end;
    EmptyQueue(qHead, qTail);
    for i:=0 to mm-1 do begin { Объединяем все очереди в одну }
      ConcatQueues(qHead, qTail, qmHead[i], qmTail[i]);
      Inc(m);
    end;
  end;
end;




procedure PrintQueue(qHead, qTail:PInf);{Процедура вывода очереди на экран и в файл}
var
  p:PInf;
begin
  p:=qHead;
  while p<>nil do begin
    Write(p^.num,' ');
    write(ftext, p^.num,' ');
    p:=p^.next;
  end;
  Writeln;
  writeln(ftext);
end;


procedure PrintInf;{Процедура вывода на экран количества операций сравнения и пересылок}
begin
  Writeln('C = ', c, ', M = ', m);
  writeln(ftext, 'C = ', c, ', M = ', m);
end;


procedure Print(var qHead, qTail:PInf; s:String; keys:integer);{Процедура вывода на экран информации об очереди}
begin
  Writeln(s,':');
  writeln(ftext, s,':');
  PrintQueue(qHead, qTail);
  Writeln;
  writeln(ftext);
  case keys of {Запуск процедуры сортировки масива взависимости от выбора в меню}
    1:pr_DirectFusion(qHead, qTail);
    2:pr_DigitalSorting(qHead, qTail);
  end;
  Writeln('Последовательность после сортировки:');
  writeln(ftext,'Последовательность после сортировки:');
  PrintQueue(qHead, qTail);
  Writeln;
  writeln(ftext);
  PrintInf;
  Writeln('Для продолжения нажмите любую клавишу...');
  ReadKey;
end;



var
  qHead,qTail:PInf; {Указатели на начало и конец очереди }
begin
  ClrScr;
  Writeln('Меню выбора метода сортировки последовательности целых чисел:');
  Writeln('1. Метод прямого слияния');
  Writeln('2. Методом цифровой сортировки');
  Write('Нажмите клавишу 1, 2');
  repeat
    key:=readkey;
  until (key in chis);
  keys:=integer(key)-48;
  str(keys:1,txt_filename);
  txt_filename:='lab3' + txt_filename + '.txt';
  assign(ftext, txt_filename); {Создаем текстовый файл lab1+метод.txt}

  {$I-}Reset(ftext);{$I+} {Ловим ошибку при отсутствии файла}
   
  if IOResult = 2 then begin
      Rewrite(ftext);{Если нет файла, создаем}
    end
   else begin
      Append(ftext);
   end;
  case keys of
    1:writeln(ftext, 'Метод прямого слияния');
    2:writeln(ftext, 'Методом цифровой сортировки');
  end;
  ClrScr; 
  Write('Введите количество элементов в последовательности:');
  Readln(kn);
  writeln(ftext, 'количество элементов в последовательности - ',kn);
  Writeln;
  RandomQueue(qHead, qTail);{Генерация элементов}
  Print(qHead, qTail, 'Случайная последовательность',keys);
  Writeln;
  writeln(ftext);
  Print(qHead, qTail, 'Упорядоченная последовательность',keys);
  close(ftext);
  Writeln('Для выхода из программы нажмите любую клавишу...');
  ReadKey;
end.


1. Исправьте свой пост, воспользуйтесь корректно тегом "code" и добавьте недостающий код.

2. Видимо, косячите с указателями. Имейте ввиду, что в BP они имеют разрядность 16, а в FPC - 32 и выше, в зависимости от режима.

Максим писал(а):1. Исправьте свой пост, воспользуйтесь корректно тегом "code" и добавьте недостающий код.

Спасибо, с тегом действительно вышел косяк, поправил...

В принципе, если код на 158 строке заменить на нижеприведённый, программа будет работать. Правда, думается, что появление такого пустого элемента в списке свидетельствует об ошибке в логике программы. В частности, подозрительно выглядит перенос элементов из списков aHead/aTail в списки cHead/cTail.

Код: Выделить всё

if cTail[k]<>nil then
  cTail[k]^.next:=nil;