home *** CD-ROM | disk | FTP | other *** search
/ Vectronix 2 / VECTRONIX2.iso / FILES_01 / KBMONITO.LZH / KBDMON.1_0 / KM_INOUT.PAS < prev   
Pascal/Delphi Source File  |  1992-08-30  |  7KB  |  296 lines
  1. unit km_inout;
  2. { diverse Ein- /Ausgabefunktionen }
  3. {$R-,S-,I+,F+}
  4.  
  5. interface
  6.  
  7. const recvd    :boolean =false;           { Statuspaket empfangen?  }
  8.  
  9. const hxdig :string[16]='0123456789ABCDEF';
  10.       crup =#72; crdo =#80;
  11.       crle =#75; crri =#77;
  12.       back =#8;  del  =#127; 
  13.       enter=#13; esc  =#27;
  14.  
  15. type  buffer   =array [0..31] of byte;
  16.  
  17. var   buffptr  :^buffer;                  { Zeiger audf Empfangsp.  }
  18.       cmdbuff  :buffer;                   { Kommandopuffer          } 
  19.       bytebuff :array [0..8191] of byte;  { Puffer f. IKBD-Memory   }
  20.  
  21. { Kursor positionieren }
  22. procedure curup   (n :integer);
  23. procedure curdown (n :integer);
  24. procedure curright(n :integer);
  25. procedure curleft (n :integer);
  26.  
  27. { Kursor ein/aus }
  28. procedure curon;
  29. procedure curoff; 
  30.  
  31. { Taste und ggf. Scancode lesen }
  32. procedure getcodes(var rd,cd :char);
  33.  
  34. { Status Eingabekanal }
  35. function charavlbl :boolean;
  36.  
  37. { String in Gro₧buchstaben wandeln }
  38. procedure upstr(var s :string);
  39.  
  40. { Zahl hexadezimal mit n Stellen ausgeben }
  41. procedure wrhex(v :word; n :longint);
  42. { Zahl Hex aus String lesen }
  43. function rdhex(hs :string): longint;
  44.  
  45. { Puffer auflisten }
  46. procedure dumpbuff(buffptr :pointer; sadr,lns :word);
  47.  
  48. { Zeile eingeben }
  49. procedure inputln(var ln :string);
  50.  
  51. { Bytes an IKBD senden }
  52. procedure sendbuff(buffptr :pointer; cntr :word);
  53.  
  54. { neuen Statusvector installieren }
  55. procedure inststatvec;
  56. { alten Vector wiederherstellen }
  57. procedure restoldvec;
  58.  
  59. { Bytes in den IKBD laden }
  60. procedure putbytes(kaddr,n :word);
  61.  
  62. { Bytes aus dem IKBD laden }
  63. procedure getbytes(kaddr,n :word);
  64.  
  65. implementation { ****************************************************** }
  66.  
  67. var  oldstvec :longint;
  68.  
  69. {*** Pointer incrementieren ***}
  70. procedure incptr(var p :pointer; d :word);
  71. begin p:=pointer(longint(p)+d); end;
  72.  
  73. {*** Kursor positionieren ***}
  74. procedure curup   (n :integer);
  75. var i :integer;
  76. begin
  77.   write(esc,'f');;
  78.   for i:=1 to n do write(esc,'A');
  79.   write(esc,'e');;
  80. end;  
  81. procedure curdown (n :integer);
  82. var i :integer;
  83. begin
  84.   write(esc,'f');;
  85.   for i:=1 to n do write(esc,'B');
  86.   write(esc,'e');;
  87. end;  
  88. procedure curright(n :integer);
  89. var i :integer;
  90. begin
  91.   write(esc,'f');;
  92.   for i:=1 to n do write(esc,'C');
  93.   write(esc,'e');;
  94. end;  
  95. procedure curleft (n :integer);
  96. var i :integer;
  97. begin
  98.   write(esc,'f');;
  99.   for i:=1 to n do write(esc,'D');
  100.   write(esc,'e');; 
  101. end; 
  102.  
  103. {*** Kursor ein/aus ***}
  104. procedure curon;
  105. begin write(esc,'e'); end;
  106. procedure curoff; 
  107. begin write(esc,'f'); end;
  108.  
  109. {*** Taste und ggf. Scancode lesen ***}
  110. procedure getcodes(var rd,cd :char);
  111. assembler;
  112. asm
  113.   move.w    #7,-(sp)
  114.   trap      #1
  115.   addq.l    #2,sp
  116.   move.l    rd,a0
  117.   move.l    cd,a1
  118.   and.l     #$00ff00ff,d0
  119.   move.w    d0,(a0)
  120.   move.w    #16,d1
  121.   lsr.l     d1,d0
  122.   move.w    d0,(a1)
  123. end; {* getcodes *}          
  124.  
  125. {*** Status Eingabekanal ***}
  126. function charavlbl :boolean;
  127. assembler;
  128. asm
  129.   move.w    #11,-(sp)
  130.   trap      #1
  131.   addq.l    #2,sp
  132.   move.w    d0,@result
  133. end;  
  134.  
  135. {*** String in Großbuchstaben wandeln ***}
  136. procedure upstr(var s :string);
  137. var i :integer;
  138. begin
  139.   for i:=1 to length(s) do s[i]:=upcase(s[i]);
  140. end; {* upstr *}
  141.  
  142. {*** Zahl hexadezimal mit n Stellen in String schreiben ***}
  143. function hexstr(v :word; n :longint): string;
  144. var   i    :integer;
  145.       hstr :string[8];
  146. begin
  147.   hstr:='';
  148.   while v>0 do
  149.   begin
  150.     hstr:=copy(hxdig,(v and $f)+1,1)+hstr;
  151.     v:=v shr 4;
  152.   end;
  153.   while length(hstr)<n do hstr:='0'+hstr;
  154.   hexstr:=hstr;
  155. end; {* hexstr *}
  156.  
  157. {*** Zahl hexadezimal mit n Stellen ausgeben ***}
  158. procedure wrhex(v :word; n :longint);
  159. begin write(hexstr(v,n),' '); end;
  160.  
  161. {*** Zahlen Hex aus String lesen ***}
  162. function rdhex(hs :string): longint;
  163. var   i,j,hxv :integer;
  164.       v       :longint;
  165. begin
  166.   v:=0; upstr(hs);
  167.   for i:=1 to length(hs) do
  168.   begin
  169.     v:=v*16;
  170.     hxv:=-1;
  171.     for j:=1 to 16 do if hs[i]=hxdig[j] then hxv:=j-1;
  172.     if hxv=-1 then
  173.     begin
  174.       rdhex:=-1; exit;
  175.     end;
  176.     v:=v+hxv;
  177.   end;
  178.   rdhex:=v;
  179. end; {* rdhex *}
  180.  
  181. {*** Puffer auflisten ***}
  182. procedure dumpbuff(buffptr :pointer; sadr,lns :word);
  183. type  btfld  =array [0..15] of byte;
  184. var   i,j    :longint;
  185.       btptr  :^btfld;
  186. begin
  187.   curoff;
  188.   write('     ');
  189.   for i:=sadr to sadr+15 do write('  ',hxdig[i mod 16+1]);
  190.   writeln;
  191.   for i:=1 to lns do
  192.   begin
  193.     wrhex(sadr,4); write(' ');
  194.     btptr:=buffptr;
  195.     incptr(buffptr,16); inc(sadr,16);
  196.     for j:=0 to 15 do wrhex(btptr^[j],2); write(' ');
  197.     for j:=0 to 15 do if btptr^[j] in [32..126] then write(chr(btptr^[j])) else write('.');
  198.     writeln;
  199.   end;
  200.   curon;
  201. end; {* dumpbuff *}
  202.  
  203. {*** Zeile eingeben ***}
  204. procedure inputln(var ln :string);
  205. var oldlen      :integer;
  206.     rdchr,cdchr :char;
  207. begin
  208.   write(ln,' '); curleft(1);
  209.   oldlen:=length(ln);
  210.   repeat
  211.     curleft(oldlen); curoff;
  212.     write(ln,' '); curleft(1);
  213.     oldlen:=length(ln);
  214.     getcodes(rdchr,cdchr);
  215.     if rdchr=back then ln:=copy(ln,1,length(ln)-1);
  216.     if rdchr in [#32..#126] then ln:=ln+rdchr;
  217.   until rdchr=enter;  
  218. end;  {* inputln *}
  219.  
  220. {*** Bytes an IKBD senden ***}
  221. procedure sendbuff(buffptr :pointer; cntr :word);
  222. assembler;
  223. asm
  224.   move.l    buffptr,-(sp)
  225.   move.w    cntr,-(sp)
  226.   move.w    #25,-(sp)
  227.   trap      #14
  228.   addq.l    #8,sp
  229. end; {* sendbuff *}  
  230.  
  231. {*** neuen Statusvector installieren *}
  232. procedure inststatvec;
  233. assembler;
  234. asm
  235.   move.w    #34,-(sp)
  236.   trap      #14
  237.   addq.l    #2,sp
  238.   move.l    d0,a0
  239.   move.l    12(a0),oldstvec
  240.   lea       @nwvc,a1
  241.   move.l    a1,12(a0)
  242.   bra       @isve
  243.  @nwvc:
  244.   move.w    #-1,recvd
  245.   move.l    a0,buffptr
  246.   move.l    oldstvec,a1
  247.   jmp       (a1)
  248.  @isve:  
  249. end; {* instvec *}
  250.  
  251. {*** alten Vector wiederherstellen ***}
  252. procedure restoldvec;
  253. assembler;
  254. asm
  255.   move.w    #34,-(sp)
  256.   trap      #14
  257.   addq.l    #2,sp
  258.   move.l    d0,a0
  259.   move.l    oldstvec,12(a0)
  260. end; {* restoldvec *}  
  261.  
  262. {*** Bytes in den IKBD laden (max. 255) ***}
  263. procedure putbytes(kaddr,n :word);
  264. begin
  265.   cmdbuff[0]:=$20;
  266.   cmdbuff[1]:=hi(kaddr);
  267.   cmdbuff[2]:=lo(kaddr);
  268.   cmdbuff[3]:=byte(n);
  269.   sendbuff(@cmdbuff,4);
  270.   sendbuff(@bytebuff,n);
  271. end; {* putbytes *}
  272.  
  273. {*** Bytes aus dem IKBD laden (max. 4096) ***}
  274. procedure getbytes(kaddr,n :word);
  275. var i,j,bidx :integer;
  276. begin
  277.   if n>8192 then n:=8192;
  278.   bidx:=0;
  279.   for i:=1 to (n div 6 +1) do
  280.   begin
  281.     cmdbuff[0]:=$21;
  282.     cmdbuff[1]:=hi(kaddr);
  283.     cmdbuff[2]:=lo(kaddr);
  284.     recvd:=false;
  285.     sendbuff(@cmdbuff,3);
  286.     repeat until recvd;
  287.     for j:=0 to 5 do bytebuff[bidx+j]:=buffptr^[1+j];
  288.     inc(bidx,6);
  289.     inc(kaddr,6);
  290.   end;
  291. end; {* getbytes *}    
  292.  
  293.  
  294. end.
  295.     
  296.