Список с заглавным звеном, из текстового файла получить список из записей и по нему уже сделать з Опции

[Zigfried]

Вот вроде исправил,а всеравно вылетает:

program lyalikov21;
{Найти телефонную сеть(первые 3 цифры номера),имеющую наибольшее число абонентов}
{$APPTYPE CONSOLE}
uses
  SysUtils;
type
  tPage = record
    FIO: string[30];
    Ul: string[20];
    Dom,Kv: integer;
    Tel: string[10];
    Bal:single
  end;
  tlist=^tElem;
  tElem = record
    Page: tPage;
    Next:tlist
  end;
var
  Spis:tlist;
   z:tPage;
   x:text;

procedure list_init(var m:tlist);
 {Инициализация списка с заглавным звеном}
  begin
   new(m);
   m^.next:=nil
  end;

procedure list_read(var z:tPage);
 {чтение из файла записи}
  begin
   readln(x,z.FIO);
   readln(x,z.Ul);
   readln(x,z.Dom);
   readln(x,z.Kv);
   readln(x,z.Tel);
   readln(x,z.Bal);
   if not eof(x) then readln(x)
  end;

function more(z1,z2:tPage):boolean;
 {Сортировка записи по имени каталога и телефону}
var
  t:boolean;
begin
  if z1.Tel<z2.Tel then t:=true
    else
      if z1.Tel=z2.Tel then
         if z1.FIO<z2.FIO then t:=true
           else
             if z1.FIO=z2.FIO then t:=true
                              else t:=false
                             else t:=false;
  more:=t
end;
 procedure list_add(var m:tlist; z:tPage);
 {Добавление записи в список, c учетом сортировки}
  var
   p,q:tlist;
  begin
   q:=m;
   while (q^.next<>nil) and more(q^.next^.Page,z) do
    q:=q^.next;
   new(p);
   p^.Page:=z;
   p^.next:=q^.next;
   q^.next:=p
  end;

procedure list_create(var x:text;var m:tlist);
 {Формирование списка из файла}
  begin
   assign(x,'input.txt');
   reset(x);
   list_init(m);
   while not seekeof(x) do
    begin
     list_read(z);
     list_add(m,z)
     end
  end;
procedure list_print(m:tlist);
 {Печать списка}
  begin
   if m=nil then writeln('konec spiska')
    else
     begin
      writeln(m^.Page.FIO);
      writeln(m^.Page.Ul);
      writeln(m^.Page.Dom);
      writeln(m^.Page.Kv);
      writeln(m^.Page.Tel);
      writeln(m^.Page.Bal:3:2);
      writeln;
      list_print(m^.next)
     end
  end;
procedure poisk(m:tlist);
 var q:tlist;
     max,k,i:integer;
     maxop:string[3];
 begin
  q:=m;
  max:=0;
  while q<>nil do
    begin
      k:=1;
      while (q^.Next^.Page.Tel=q^.Page.Tel) and (q^.Next<>nil) do
       begin
        k:=k+1;
        q:=q^.Next
       end;
      if k>max then
       begin
       max:=k;
       for i:=1 to 3 do
           maxop[i]:=q^.page.tel[i]
       end;
      q:=q^.Next
     end;
  dispose(q);
  for i:=1 to 3 do
   writeln('max operator',maxop[i]);
  writeln('vstrechaetsa',max,'raz');
  readln;
  readln
 end;
procedure del(var m:tlist);
 {Удаление списка}
  var
   p:tlist;
  begin
   while m<>nil do
    begin
     p:=m;
     m:=m^.next;
     dispose(p)
    end
  end;

begin
  { TODO -oUser -cConsole Main : Insert code here }
  list_create(x,spis);
  Writeln('spisok:');
  list_print(spis^.next);
  poisk(spis);
  close(x);
  del(spis);
  readln;
  readln
end.

При вылете успел сфотать что выдаёт:
Exception EAccessViolation in module lyalikov21.exe at 00008CE2.
Access violation at address 00408CE2 in module 'lyalikov21.exe'. Read of address 0000003C.

[volvo]

Что-то ты перемудрил в процедуре Poisk. Смотри:

procedure poisk(m: TList);
var
  q: TList;
  maxOp: string[3];
  k, max: integer;
begin
  q := m^.next; // первый элемент - пропускаем, он заглавный...
  max := 0;
  while q <> nil do // а теперь идем по списку...
  begin
    k := 1; // считать начинаем с 1, одно-то вхождение все равно есть.

    // Здесь внимательно: сначала проверим, существует ли q, потом - 
    // существует ли q^.next, и только потом сравниваем текущий и следующий
    // элементы списка...
    while (q <> nil) and (q^.next <> nil) and
          (copy(q^.page.tel, 1, 3) = copy(q^.next^.page.tel, 1, 3)) do // сравнить первые 3 символа
    begin
      inc(k);
      q := q^.next;
    end;

    if k > max then // тут у тебя все было правильно, только заполни maxop без цикла
    begin
      max := k;
      maxop := copy(q^.page.tel, 1, 3);
    end;

    // а вот это - ключевой момент: продвигаемся дальше - только если k = 1,
    // то есть, только если внутри предыдущего цикла не было увеличения q...
    if k = 1 then
      q := q^.next;
  end;

  writeln('max operator: ', maxop);
  writeln('vstrechaetsa: ', max, ' raz(a)');

end;

Вот это только что прогнал на FPC - не вылетает. Учти, я гонял только до закрытия файла, дальше - тебе еще список удалять надо, ты этого так и не сделал... И не надо q^ удалять в Poisk-е. Ты ж место под него ТАМ не выделял, зачем удаляешь?

[Zigfried]

Спасибо большое,исправил,работает)