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