unit tekscimy;
interface
uses
 exec;

type
 ptdtext = ^tdtext;
 tdtext  = record
             tsize  : integer;                 { dlugosc tekstu }
             twsk   : pointer;                 { wskaznik do tekstu C }
             otherp : array [1..2] of ptdtext; { 1-poprzedni, 2-nastepny}
           end;
           { NIE WOLNO ZMIENIAC KOLEJNOSCI KOMPONENTOW
             cala struktura jest liniowa
             kazdy tekst konczy sie #0, ale dlugosc czy tekst jest podawany
             bez tego znaku !!! }
 ardtext = array [0..1] of ptdtext; { [0] - baza }

procedure relpointer(o_ile   : longint;
                     var wsk : ptdtext);
function getlen(wsk : ptdtext) : byte;
function getext(wsk : ptdtext) : string;
function getptr(wsk : ptdtext) : pointer;
procedure setext(wsk : ptdtext;
                 tk  : string);
procedure cleartext(wsk : ptdtext);
procedure eraseptr(var wsk : ptdtext);
procedure clearall(var wsk : ptdtext);
procedure addtext(var wsk : ptdtext;
                  tk      : string);
procedure includetext(var wsk1,p1,p2 : ptdtext);

implementation

procedure relpointer;
xassembler;
asm
  movem.l a0-a2,-(sp)  { adresowe na stos }
  moveq #10,d1         { d1:=10; offset [2] w tdtext }
  lea $10(sp),a1       { a1:=adres argumentow }
  movea.l (a1)+,a2     { a2:=adres adresu ptdtextu }
  movea.l (a2),a0      { a0:=adres ptdtextu }
  move.l (a1)+,d0      { d0:=o ile przesunac }
  bpl @label           { jesli d0<0 to }
  moveq #6,d1          { d1:=6; offset [1] w tdtext }
  neg.l d0             { d0:=-d0 }
  @label: bra @et
  @loop: adda.l d1,a0  { dodaj offset }
  movea.l (a0),a0      { a0:=adres nastepnego ptdtext }
  @et: cmp.l #0,a0     { jesli a0=0 }
  beq @finish          { to end }
  dbeq d0,@loop        { jesli licznik=0 to end }
  @finish:
  move.l a0,(a2)       { zapisz adres }
  movem.l (sp)+,a0-a2  { ze stosu }
end;

function getlen;
begin
  if wsk=nil then
    getlen:=0
  else
    getlen:=wsk^.tsize;
end;

function getext;
var
 tk : string;
begin
  asm
    clr.l d0
    lea tk,a1
    movea.l wsk,a2
    cmpa.l #0,a2
    beq @save                  { jezeli adres struktury=0, to tekst = '' }
    move.w (a2)+,d0            { d0:=dlugosc tekstu }
    @save: movea.l (a2),a0     { a0:=adres dtekstu }
    move.b d0,(a1)+            { zapisz dlugosc }
    bra @et
    @loop: move.b (a0)+,(a1)+  { skopiowanie tekstu }
    @et: dbeq d0,@loop         { petla }
  end;
  getext:=tk;
end;

function getptr;
begin
  if wsk=nil then
    getptr:=nil
  else
    getptr:=wsk^.twsk;
end;

procedure setext;
var
 p : pointer;
 f : integer;
begin
  f:=length(tk)+1;
  p:=allocmem(f,MEMF_FAST);
  if p=nil then
    p:=allocmem(f,MEMF_PUBLIC);
  wsk^.twsk:=p;
  asm
    clr.l d0
    lea tk,a0
    movea.l wsk,a2
    move.b (a0)+,d0           { d0:=dlugosc tekstu }
    move.w d0,(a2)+           { zapisz d0 do tsize'a }
    movea.l (a2),a1           { a1:=adres dtekstu }
    bra @et
    @loop: move.b (a0)+,(a1)+ { kopiowanie }
    @et: dbeq d0,@loop        { petla }
    clr.b (a1)                { ostatnim znakiem jest #0 }
  end;
end;

procedure cleartext;
begin
  if wsk<>nil then
    with wsk^ do
    begin
      if twsk<>nil then
        freemem(twsk,tsize+1);
      twsk:=nil;
      tsize:=0;
    end;
end;

procedure eraseptr;
begin
  if wsk<>nil then
  begin
    cleartext(wsk);
    if wsk^.otherp[1]<>nil then
      wsk^.otherp[1]^.otherp[2]:=wsk^.otherp[2];
    if wsk^.otherp[2]<>nil then
      wsk^.otherp[2]^.otherp[1]:=wsk^.otherp[1];
    dispose(wsk);
  end;
end;

procedure clearall;
begin
  if wsk<>nil then
  begin
    while wsk^.otherp[2]<>nil do
    begin
      wsk:=wsk^.otherp[2];
      eraseptr(wsk^.otherp[1]);
    end;
    eraseptr(wsk);
    wsk:=nil;
  end;
end;

procedure addtext;
var
 tmpp : ptdtext;
 p    : pointer;
begin
  p:=allocmem($e,MEMF_FAST);
  if p=nil then
    p:=allocmem($e,MEMF_PUBLIC);
  tmpp:=p;
  setext(tmpp,tk);
  tmpp^.otherp[1]:=wsk;
  tmpp^.otherp[2]:=nil;
  if wsk<>nil then
    wsk^.otherp[2]:=tmpp;
  wsk:=tmpp;
end;

procedure includetext;
var
 wsk2 : ptdtext;
begin
  wsk2:=nil;
  if wsk1<>nil then
    wsk2:=wsk1^.otherp[2];
  p1^.otherp[1]:=wsk1;
  p2^.otherp[2]:=wsk2;
  if wsk1<>nil then
    wsk1^.otherp[2]:=p1;
  if wsk2<>nil then
    wsk2^.otherp[1]:=p2;
end;

end.