В-Дерево во внешней памяти

 const
  t = 4;
 
var
  deskfname: string;
  btreefname: string;
  f1: text;
  count: integer;
  a: array [1..20] of integer;
  i:integer;
 
type
  btnode = record
    pos: integer;
    leaf: boolean;
    n: integer;
    key: array[1..2 * t - 1] of integer;
    c: array[1..2 * t] of integer;
  end;
 
function GetRootPos: integer;
var
  ppos: integer;s: string;
begin
  Assign(f1, deskfname);
  reset(f1);
  readln(f1, s);
  read(f1, ppos);
  close(f1);
  GetRootPos := ppos;
end;
 
procedure SetRootPos(p: integer);
var
  f1:text;
begin
  Assign(f1, deskfname);
  rewrite(f1);
  writeln(f1, btreefname);
  writeln(f1, p);
   writeln(f1, count); 
  close(f1);
end;
 
procedure PrintFile;
var
  x: btnode;i: integer;
  f: file of btnode;
begin
  Writeln('Pos ', 'Leaf  ', 'Nkey ', 'Keys ':21, 'Ref':5);
  Assign(f, btreefname);
  reset(f); 
  if eof(f)
    then writeln('File is empty!')
  else while not eof(f) do
    begin
      read(f, x);
      Write(x.pos:2, x.leaf:7, x.n:5, ' ');
      for i := 1 to x.n do 
        write(x.key[i]:3);
      for i := 1 to x.n + 1 do
        if x.n <> 0
          then write(x.c[i]:3);
      writeln;
    end;
  close(f);
end;
 
procedure Allocate_Node(var x: btnode);
var
  i: integer;
begin
  x.pos := 0;
  x.n := 0;
  x.leaf := false;
  for i := 1 to 2 * t - 1 do
  begin
    x.key[i] := -1;
    x.c[i] := -1;
  end;
  x.c[2 * t] := -1;
end;
 
procedure BTreeCreate(TFileName: string; DFileName: string );
var
  root: btnode;
  f: file of btnode;
begin
  Allocate_Node(root);
  root.n := 0;
  root.leaf := true;
  root.pos := 1;
  Assign(f1, DFileName);
  rewrite(f1);
  Writeln(f1, TFileName);
  Writeln(f1, 1);
  Writeln(f1, 1);
  close(f1);
  Assign(f, TFileName);
  rewrite(f);
  Write(f, root);
  close(f);
end;
 
procedure DiskRead(x: integer; var node: btnode; btreefname: string);
var
  f: file of btnode;fl:boolean;
begin
  Assign(f, btreefname);
  fl := false;
  reset(f);
  read (f,node);
  while not eof(f) and not fl do
  begin
    read(f, node);
    if node.pos = x
    then begin
        fl:=true;
        close (f);
        exit;
    end;
  end;
  close(f);
end;
 
function FreePos: integer;
var
  f: file of btnode;
  n: longint;
begin
  Assign(f, btreefname);
  reset(f); 
  n := FileSize(f);
  close(f);
  FreePos := n;
end;
 
procedure DiskWrite( x: btnode);
var
  f: file of btnode;
begin
  Assign(f, btreefname);
  if Count = 1
  then rewrite(f)
  else reset (f);
  Seek(f, x.pos);
  if (x.n > 0)  and (x.pos > 0)
  then write(f, x);
  close(f)
end;
 
procedure SplitChild(var x, y: BTNode; i: integer);
var
  z: BTNode;
  j: integer;
begin
  Allocate_Node(z);
  z.leaf := y.leaf;
  z.n := t - 1;
  z.pos := FreePos+1;
  for j := 1 to t - 1 do
    z.key[j] := y.key[j + t];
  if not y.leaf then
    for j := 1 to t do
      z.c[j] := y.c[j + t];
  y.n := t - 1;
  for j := x.n + 1 downto i + 1 do
    x.c[j + 1] := x.c[j];
  x.c[i + 1] := z.pos;
  for j := x.n downto i do
    x.key[j + 1] := x.key[j];
  x.key[i] := y.key[t];
  x.n := x.n + 1;
  DiskWrite(x);
  DiskWrite(y);
  DiskWrite(z);
end;
 
procedure InsertNonFull(var x: BTNode; k: integer);
var
  i: integer;
  y: BTNode;
begin
  i := x.n;
  if x.leaf then
  begin
    while (i >= 1) and (k < x.key[i]) do
    begin
      x.key[i + 1] := x.key[i];
      i := i - 1;
    end;
    x.key[i + 1] := k;
    x.n := x.n + 1;
    DiskWrite(x);
  end
   else
  begin
    while (i >= 1) and (k < x.key[i]) do
      i := i - 1;
    i := i + 1;
    DiskRead(x.c[i], x, btreefname);
    y.c[i] := x.c[i]; 
    if y.n = 2 * t - 1 then
    begin
      SplitChild(x, y, i);
      if k > x.key[i] then
      begin
        i := i + 1;
        DiskRead(y.pos, x, btreefname);
        y.c[i] := x.c[i]; 
      end;
    end;
    InsertNonFull(y, k);
  end;
end;
 
procedure Insert(var k: integer);
var
  s, r: BTNode;
  RootPos: integer;
begin
  DiskRead(GetRootPos, r, btreefname);
  if r.n = 2 * t - 1 then
  begin
    Allocate_Node(s); 
    s.leaf := false;
    s.n := 0;
    s.pos := FreePos;
    s.c[1] := r.pos;
    SetRootPos(s.pos);
    SplitChild(s, r, 1);
    InsertNonFull(s, k);
  end
  else InsertNonFull(r, k);//тут стек и переполняется
end;
 
begin
  { writeln('Deskriptor file name ');
   readln(deskfname);
   writeln('Tree file name ');
   readln(btreefname);}
  deskfname := 'desk.txt';
  btreefname := 'bt.dat';
  BTreeCreate(btreeFName, deskFName);
   for i:= 1 to 10 do  
  read(a[i]);
  for i := 1 to 10 do
  insert (a[i]);
  PrintFile();
end.