Rev Author Line No. Line
204 miho 1 unit PP_COMON;
2  
3 {===========================================================================}
4 { (c) miho / DECROS 2000 }
5 {===========================================================================}
6 { Zde jsou obecne uzivane pomocne procedury a funkce . }
7 {===========================================================================}
8  
9 interface
10  
11 function UpStr(str:string):string;
12 {== Prevede retezec na velka pismena ==}
13  
14 procedure PressEnter;
15 {== Zobrazi hlasku a ceka na stisk klavesy ==}
16  
17 procedure HexByte(var f:text;data:word);
18 {== Vytiskni byte jako 2 znaky ==}
19  
20 procedure HexWord(var f:text;data:word);
21 {== Vytiskni word jako 4 znaky ==}
22  
23 procedure HexWordSp(var f:text;data:word);
24 {== Vytiskni word jako 4 znaky a mezeru ==}
25  
26 procedure HexAdr(var f:text;data:word);
27 {== Vytiskni adresu s dvojteckou ==}
28  
29 procedure Error(ErrorStr:string; LineNumber:integer); (* !! *)
30 {== Vytiskne hlaseni o chybe a ukonci program ==}
31 { Pokud je LinNumber<=0 pak se netiskne }
32  
33 function DelSpace(s:string):string;
34 {== Vyhodi vsechny mezery ze zacatku retezce s ==}
35  
36 function GetWord(s:string):string;
37 {== Vrati prvni slovo ze zadaneho retezce ==}
38  
39 function DelWord(s:string):string;
40 {== Odstrihne prvni slovo z retezce ==}
41  
42 procedure DisplayRange(Base, Len:word);
43 {== obrazi rozsah jako dvojici hex cisel ==}
44  
45 function GetParamLine(First:integer):string;
46 {== slozi vsechny parametry od First a vrati UpCase tohoto slozeni ==}
47  
48 implementation
49  
50 function UpStr(str:string):string;
51 {== Prevede retezec na velka pismena ==}
52 var i:integer;
53 begin for i:=1 to length(str) do str[i]:=upcase(str[i]);
54 UpStr:=str;
55 end; {UpStr}
56  
57 procedure PressEnter;
58 {== Zobrazi hlasku a ceka na stisk klavesy ==}
59 begin write('Press ENTER to continue ...');
60 readln;
61 writeln;
62 end; {PressEnter}
63  
64 const prevod:array[0..15]of char=('0','1','2','3','4','5','6','7',
65 '8','9','A','B','C','D','E','F');
66  
67 procedure HexByte(var f:text;data:word);
68 {== Vytiskni byte jako 2 znaky ==}
69 begin write(f, prevod[(data shr 4) and $F],
70 prevod[data and $F]);
71 end; {HexByte}
72  
73 procedure HexWord(var f:text;data:word);
74 {== Vytiskni word jako 4 znaky ==}
75 begin write(f, prevod[(data shr 12) and $F],
76 prevod[(data shr 8) and $F],
77 prevod[(data shr 4) and $F],
78 prevod[data and $F]);
79 end; {HexWord}
80  
81 procedure HexWordSp(var f:text;data:word);
82 {== Vytiskni word jako 4 znaky a mezeru ==}
83 begin write(f, prevod[(data shr 12) and $F],
84 prevod[(data shr 8) and $F],
85 prevod[(data shr 4) and $F],
86 prevod[data and $F],
87 ' ');
88 end; {HexWordSp}
89  
90 procedure HexAdr(var f:text;data:word);
91 {== Vytiskni adresu s dvojteckou ==}
92 begin write(f, prevod[(data shr 12) and $F],
93 prevod[(data shr 8) and $F],
94 prevod[(data shr 4) and $F],
95 prevod[data and $F],
96 ': ');
97 end; {HexAdr}
98  
99 procedure Error(ErrorStr:string; LineNumber:integer);
100 {== Vytiskne hlaseni o chybe a ukonci program ==}
101 { Pokud je LinNumber<=0 pak se netiskne }
102 begin writeln;
103 if LineNumber<=0 then writeln('FATAL: ',ErrorStr)
104 else writeln('FATAL @ Line ',LineNumber,': ',ErrorStr);
105 writeln;
106 halt(1);
107 end; {Error}
108  
109 function DelSpace(s:string):string;
110 {== Vyhodi vsechny mezery ze zacatku retezce s ==}
111 var i:integer;
112 begin i:=1;
113 while (i<=length(s)) and (s[i]=' ')
114 do inc(i);
115 DelSpace:=copy(s,i,255);
116 end; {DelSpace}
117  
118 function GetWord(s:string):string;
119 {== Vrati prvni slovo ze zadaneho retezce ==}
120 var t:string;
121 begin t:=DelSpace(s);
122 GetWord:=copy(t,1,pos(' ',t+' ')-1);
123 end; {GetWord}
124  
125 function DelWord(s:string):string;
126 {== Odstrihne prvni slovo z retezce ==}
127 var t:string;
128 begin t:=DelSpace(s);
129 t:=copy(t,pos(' ',t+' ')+1,255);
130 DelWord:=DelSpace(t);
131 end; {DelWord}
132  
133 procedure DisplayRange(Base, Len:word);
134 {== obrazi rozsah jako dvojici hex cisel ==}
135 begin if Len<>0
136 then begin hexword(Output,Base);
137 write('..');
138 hexword(Output,Base+Len-1);
139 write(' ');
140 end
141 else begin write('none ');
142 end;
143 end; {DisplayRange}
144  
145 function GetParamLine(First:integer):string;
146 {== slozi vsechny parametry od First a vrati UpCase tohoto slozeni ==}
147 var i:integer;
148 s:string;
149 begin s:='';
150 if First<1 then exit;
151 for i:=First to paramcount do s:=s+paramstr(i)+' ';
152 GetParamLine:=UpStr(s);
153 end; {GetParamLine}
154  
155 begin
156 end.