/Modules/PICPGR3/PICPGR301A/SW/4_12/PP_COMON.PAS
0,0 → 1,156
unit PP_COMON;
 
{===========================================================================}
{ (c) miho / DECROS 2000 }
{===========================================================================}
{ Zde jsou obecne uzivane pomocne procedury a funkce . }
{===========================================================================}
 
interface
 
function UpStr(str:string):string;
{== Prevede retezec na velka pismena ==}
 
procedure PressEnter;
{== Zobrazi hlasku a ceka na stisk klavesy ==}
 
procedure HexByte(var f:text;data:word);
{== Vytiskni byte jako 2 znaky ==}
 
procedure HexWord(var f:text;data:word);
{== Vytiskni word jako 4 znaky ==}
 
procedure HexWordSp(var f:text;data:word);
{== Vytiskni word jako 4 znaky a mezeru ==}
 
procedure HexAdr(var f:text;data:word);
{== Vytiskni adresu s dvojteckou ==}
 
procedure Error(ErrorStr:string; LineNumber:integer); (* !! *)
{== Vytiskne hlaseni o chybe a ukonci program ==}
{ Pokud je LinNumber<=0 pak se netiskne }
 
function DelSpace(s:string):string;
{== Vyhodi vsechny mezery ze zacatku retezce s ==}
 
function GetWord(s:string):string;
{== Vrati prvni slovo ze zadaneho retezce ==}
 
function DelWord(s:string):string;
{== Odstrihne prvni slovo z retezce ==}
 
procedure DisplayRange(Base, Len:word);
{== obrazi rozsah jako dvojici hex cisel ==}
 
function GetParamLine(First:integer):string;
{== slozi vsechny parametry od First a vrati UpCase tohoto slozeni ==}
 
implementation
 
function UpStr(str:string):string;
{== Prevede retezec na velka pismena ==}
var i:integer;
begin for i:=1 to length(str) do str[i]:=upcase(str[i]);
UpStr:=str;
end; {UpStr}
 
procedure PressEnter;
{== Zobrazi hlasku a ceka na stisk klavesy ==}
begin write('Press ENTER to continue ...');
readln;
writeln;
end; {PressEnter}
 
const prevod:array[0..15]of char=('0','1','2','3','4','5','6','7',
'8','9','A','B','C','D','E','F');
 
procedure HexByte(var f:text;data:word);
{== Vytiskni byte jako 2 znaky ==}
begin write(f, prevod[(data shr 4) and $F],
prevod[data and $F]);
end; {HexByte}
 
procedure HexWord(var f:text;data:word);
{== Vytiskni word jako 4 znaky ==}
begin write(f, prevod[(data shr 12) and $F],
prevod[(data shr 8) and $F],
prevod[(data shr 4) and $F],
prevod[data and $F]);
end; {HexWord}
 
procedure HexWordSp(var f:text;data:word);
{== Vytiskni word jako 4 znaky a mezeru ==}
begin write(f, prevod[(data shr 12) and $F],
prevod[(data shr 8) and $F],
prevod[(data shr 4) and $F],
prevod[data and $F],
' ');
end; {HexWordSp}
 
procedure HexAdr(var f:text;data:word);
{== Vytiskni adresu s dvojteckou ==}
begin write(f, prevod[(data shr 12) and $F],
prevod[(data shr 8) and $F],
prevod[(data shr 4) and $F],
prevod[data and $F],
': ');
end; {HexAdr}
 
procedure Error(ErrorStr:string; LineNumber:integer);
{== Vytiskne hlaseni o chybe a ukonci program ==}
{ Pokud je LinNumber<=0 pak se netiskne }
begin writeln;
if LineNumber<=0 then writeln('FATAL: ',ErrorStr)
else writeln('FATAL @ Line ',LineNumber,': ',ErrorStr);
writeln;
halt(1);
end; {Error}
 
function DelSpace(s:string):string;
{== Vyhodi vsechny mezery ze zacatku retezce s ==}
var i:integer;
begin i:=1;
while (i<=length(s)) and (s[i]=' ')
do inc(i);
DelSpace:=copy(s,i,255);
end; {DelSpace}
 
function GetWord(s:string):string;
{== Vrati prvni slovo ze zadaneho retezce ==}
var t:string;
begin t:=DelSpace(s);
GetWord:=copy(t,1,pos(' ',t+' ')-1);
end; {GetWord}
 
function DelWord(s:string):string;
{== Odstrihne prvni slovo z retezce ==}
var t:string;
begin t:=DelSpace(s);
t:=copy(t,pos(' ',t+' ')+1,255);
DelWord:=DelSpace(t);
end; {DelWord}
 
procedure DisplayRange(Base, Len:word);
{== obrazi rozsah jako dvojici hex cisel ==}
begin if Len<>0
then begin hexword(Output,Base);
write('..');
hexword(Output,Base+Len-1);
write(' ');
end
else begin write('none ');
end;
end; {DisplayRange}
 
function GetParamLine(First:integer):string;
{== slozi vsechny parametry od First a vrati UpCase tohoto slozeni ==}
var i:integer;
s:string;
begin s:='';
if First<1 then exit;
for i:=First to paramcount do s:=s+paramstr(i)+' ';
GetParamLine:=UpStr(s);
end; {GetParamLine}
 
begin
end.