unit km_inout;
{ diverse Ein- /Ausgabefunktionen }
{$R-,S-,I+,F+}

interface

const recvd    :boolean =false;           { Statuspaket empfangen?  }

const hxdig :string[16]='0123456789ABCDEF';
      crup =#72; crdo =#80;
      crle =#75; crri =#77;
      back =#8;  del  =#127; 
      enter=#13; esc  =#27;

type  buffer   =array [0..31] of byte;

var   buffptr  :^buffer;                  { Zeiger audf Empfangsp.  }
      cmdbuff  :buffer;                   { Kommandopuffer          } 
      bytebuff :array [0..8191] of byte;  { Puffer f. IKBD-Memory   }

{ Kursor positionieren }
procedure curup   (n :integer);
procedure curdown (n :integer);
procedure curright(n :integer);
procedure curleft (n :integer);

{ Kursor ein/aus }
procedure curon;
procedure curoff; 

{ Taste und ggf. Scancode lesen }
procedure getcodes(var rd,cd :char);

{ Status Eingabekanal }
function charavlbl :boolean;

{ String in Grožbuchstaben wandeln }
procedure upstr(var s :string);

{ Zahl hexadezimal mit n Stellen ausgeben }
procedure wrhex(v :word; n :longint);
{ Zahl Hex aus String lesen }
function rdhex(hs :string): longint;

{ Puffer auflisten }
procedure dumpbuff(buffptr :pointer; sadr,lns :word);

{ Zeile eingeben }
procedure inputln(var ln :string);

{ Bytes an IKBD senden }
procedure sendbuff(buffptr :pointer; cntr :word);

{ neuen Statusvector installieren }
procedure inststatvec;
{ alten Vector wiederherstellen }
procedure restoldvec;

{ Bytes in den IKBD laden }
procedure putbytes(kaddr,n :word);

{ Bytes aus dem IKBD laden }
procedure getbytes(kaddr,n :word);

implementation { ****************************************************** }

var  oldstvec :longint;

{*** Pointer incrementieren ***}
procedure incptr(var p :pointer; d :word);
begin p:=pointer(longint(p)+d); end;

{*** Kursor positionieren ***}
procedure curup   (n :integer);
var i :integer;
begin
  write(esc,'f');;
  for i:=1 to n do write(esc,'A');
  write(esc,'e');;
end;  
procedure curdown (n :integer);
var i :integer;
begin
  write(esc,'f');;
  for i:=1 to n do write(esc,'B');
  write(esc,'e');;
end;  
procedure curright(n :integer);
var i :integer;
begin
  write(esc,'f');;
  for i:=1 to n do write(esc,'C');
  write(esc,'e');;
end;  
procedure curleft (n :integer);
var i :integer;
begin
  write(esc,'f');;
  for i:=1 to n do write(esc,'D');
  write(esc,'e');; 
end; 

{*** Kursor ein/aus ***}
procedure curon;
begin write(esc,'e'); end;
procedure curoff; 
begin write(esc,'f'); end;

{*** Taste und ggf. Scancode lesen ***}
procedure getcodes(var rd,cd :char);
assembler;
asm
  move.w    #7,-(sp)
  trap      #1
  addq.l    #2,sp
  move.l    rd,a0
  move.l    cd,a1
  and.l     #$00ff00ff,d0
  move.w    d0,(a0)
  move.w    #16,d1
  lsr.l     d1,d0
  move.w    d0,(a1)
end; {* getcodes *}          

{*** Status Eingabekanal ***}
function charavlbl :boolean;
assembler;
asm
  move.w    #11,-(sp)
  trap      #1
  addq.l    #2,sp
  move.w    d0,@result
end;  

{*** String in Groábuchstaben wandeln ***}
procedure upstr(var s :string);
var i :integer;
begin
  for i:=1 to length(s) do s[i]:=upcase(s[i]);
end; {* upstr *}

{*** Zahl hexadezimal mit n Stellen in String schreiben ***}
function hexstr(v :word; n :longint): string;
var   i    :integer;
      hstr :string[8];
begin
  hstr:='';
  while v>0 do
  begin
    hstr:=copy(hxdig,(v and $f)+1,1)+hstr;
    v:=v shr 4;
  end;
  while length(hstr)<n do hstr:='0'+hstr;
  hexstr:=hstr;
end; {* hexstr *}

{*** Zahl hexadezimal mit n Stellen ausgeben ***}
procedure wrhex(v :word; n :longint);
begin write(hexstr(v,n),' '); end;

{*** Zahlen Hex aus String lesen ***}
function rdhex(hs :string): longint;
var   i,j,hxv :integer;
      v       :longint;
begin
  v:=0; upstr(hs);
  for i:=1 to length(hs) do
  begin
    v:=v*16;
    hxv:=-1;
    for j:=1 to 16 do if hs[i]=hxdig[j] then hxv:=j-1;
    if hxv=-1 then
    begin
      rdhex:=-1; exit;
    end;
    v:=v+hxv;
  end;
  rdhex:=v;
end; {* rdhex *}

{*** Puffer auflisten ***}
procedure dumpbuff(buffptr :pointer; sadr,lns :word);
type  btfld  =array [0..15] of byte;
var   i,j    :longint;
      btptr  :^btfld;
begin
  curoff;
  write('     ');
  for i:=sadr to sadr+15 do write('  ',hxdig[i mod 16+1]);
  writeln;
  for i:=1 to lns do
  begin
    wrhex(sadr,4); write(' ');
    btptr:=buffptr;
    incptr(buffptr,16); inc(sadr,16);
    for j:=0 to 15 do wrhex(btptr^[j],2); write(' ');
    for j:=0 to 15 do if btptr^[j] in [32..126] then write(chr(btptr^[j])) else write('.');
    writeln;
  end;
  curon;
end; {* dumpbuff *}

{*** Zeile eingeben ***}
procedure inputln(var ln :string);
var oldlen      :integer;
    rdchr,cdchr :char;
begin
  write(ln,' '); curleft(1);
  oldlen:=length(ln);
  repeat
    curleft(oldlen); curoff;
    write(ln,' '); curleft(1);
    oldlen:=length(ln);
    getcodes(rdchr,cdchr);
    if rdchr=back then ln:=copy(ln,1,length(ln)-1);
    if rdchr in [#32..#126] then ln:=ln+rdchr;
  until rdchr=enter;  
end;  {* inputln *}

{*** Bytes an IKBD senden ***}
procedure sendbuff(buffptr :pointer; cntr :word);
assembler;
asm
  move.l    buffptr,-(sp)
  move.w    cntr,-(sp)
  move.w    #25,-(sp)
  trap      #14
  addq.l    #8,sp
end; {* sendbuff *}  

{*** neuen Statusvector installieren *}
procedure inststatvec;
assembler;
asm
  move.w    #34,-(sp)
  trap      #14
  addq.l    #2,sp
  move.l    d0,a0
  move.l    12(a0),oldstvec
  lea       @nwvc,a1
  move.l    a1,12(a0)
  bra       @isve
 @nwvc:
  move.w    #-1,recvd
  move.l    a0,buffptr
  move.l    oldstvec,a1
  jmp       (a1)
 @isve:  
end; {* instvec *}

{*** alten Vector wiederherstellen ***}
procedure restoldvec;
assembler;
asm
  move.w    #34,-(sp)
  trap      #14
  addq.l    #2,sp
  move.l    d0,a0
  move.l    oldstvec,12(a0)
end; {* restoldvec *}  

{*** Bytes in den IKBD laden (max. 255) ***}
procedure putbytes(kaddr,n :word);
begin
  cmdbuff[0]:=$20;
  cmdbuff[1]:=hi(kaddr);
  cmdbuff[2]:=lo(kaddr);
  cmdbuff[3]:=byte(n);
  sendbuff(@cmdbuff,4);
  sendbuff(@bytebuff,n);
end; {* putbytes *}

{*** Bytes aus dem IKBD laden (max. 4096) ***}
procedure getbytes(kaddr,n :word);
var i,j,bidx :integer;
begin
  if n>8192 then n:=8192;
  bidx:=0;
  for i:=1 to (n div 6 +1) do
  begin
    cmdbuff[0]:=$21;
    cmdbuff[1]:=hi(kaddr);
    cmdbuff[2]:=lo(kaddr);
    recvd:=false;
    sendbuff(@cmdbuff,3);
    repeat until recvd;
    for j:=0 to 5 do bytebuff[bidx+j]:=buffptr^[1+j];
    inc(bidx,6);
    inc(kaddr,6);
  end;
end; {* getbytes *}    


end.
    
