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. |