1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
|
{$j+}
{$P+}
type
CharA4 = array [1..4] of char;
CharA6 = array [1..6] of char;
String4 = String[4];
String5 = String[5];
String6 = String[6];
String8 = String[8];
const
car4_1 : CharA4 = 'ABCD';
car4_2 : CharA4 = 'abcd';
car6_1 : CharA6 = 'EFGHIJ';
car6_2 : CharA6 = 'efghij';
cst4_1 : String4 = 'ABCD';
cst6_2 : string6 = 'EFGHIJ';
cst8_1 : string8 = 'abcd';
cst8_2 : string8 = 'efghij';
var
ar4_1, ar4_2 : CharA4;
ar6_1, ar6_2 : CharA6;
st4_1, st4_2 : string4;
st5_1, st5_2 : string5;
st6_1, st6_2 : string6;
st8_1, st8_2 : string8;
pc : pchar;
const
has_errors : boolean = false;
procedure error(const st : string);
begin
Writeln('Error: ',st);
has_errors:=true;
end;
procedure testvalueconv(st : string4);
begin
Writeln('st=',st);
Writeln('Length(st)=',Length(st));
If Length(st)>4 then
Error('string length too big in calling value arg');
end;
procedure testconstconv(const st : string4);
begin
Writeln('st=',st);
Writeln('Length(st)=',Length(st));
If Length(st)>4 then
Error('string length too big in calling const arg');
end;
procedure testvarconv(var st : string4);
begin
Writeln('st=',st);
Writeln('Length(st)=',Length(st));
If Length(st)>4 then
Error('string length too big in calling var arg');
end;
{ is global switch, can't turn off here }
{P-}
procedure testvarconv2(var st : string4);
begin
Writeln('st=',st);
Writeln('Length(st)=',Length(st));
If Length(st)>4 then
Error('string length too big in calling var arg without openstring');
end;
begin
{ compare array of char to constant strings }
Writeln('Testing if "',car4_1,'" is equal to "',cst4_1,'"');
if car4_1<>cst4_1 then
error('Comparison of array of char and string don''t work');
Writeln('Testing if "',car4_1,'" is equal to "ABCD"');
if car4_1<>'ABCD' then
error('Comparison of array of char and constat string don''t work');
Writeln('Testing if "',cst4_1,'" is equal to "ABCD"');
if 'ABCD'<>cst4_1 then
error('Comparison of string and constant string don''t work');
car4_1:='AB'#0'D';
if car4_1='AB' then
Writeln('Anything beyond a #0 is ignored')
else if car4_1='AB'#0'D' then
Writeln('Chars after #0 are not ignored')
else
Error('problems if #0 in array of char');
{$ifdef FPC this is not allowed in BP !}
car4_1:=cst4_1;
{ if it is allowed then it must also work correctly !! }
Writeln('Testing if "',car4_1,'" is equal to "',cst4_1,'"');
if car4_1<>cst4_1 then
error('Comparison of array of char and string don''t work');
{$ifdef test_known_problems}
if string4(car6_2)<>'efgh' then
error('typcasting to shorter strings leads to problems');
{$endif}
ar4_2:='Test';
ar4_1:=cst6_2;
if ar4_2<>'Test' then
error('overwriting beyond char array size');
ar6_1:='Test'#0'T';
st6_1:=ar6_1;
if (st6_1<>ar6_1) or (st6_1='Test') then
error('problems with #0');
ar6_1:='AB';
if ar6_1='AB'#0't'#0'T' then
Error('assigning strings to array of char does not zero end of array if string is shorter');
if ar6_1='AB'#0#0#0#0 then
writeln('assigning shorter strings to array of char does zero rest of array')
else
error('assigning "AB" to ar6_1 gives '+ar6_1);
{$endif}
cst8_1:=car4_1;
{ if it is allowed then it must also work correctly !! }
Writeln('Testing if "',car4_1,'" is equal to "',cst8_1,'"');
if car4_1<>cst8_1 then
error('Comparison of array of char and string don''t work');
st4_2:='Test';
st4_1:=car6_1;
if (st4_2<>'Test') or (st4_1<>'EFGH') then
error('problems when copying long char array to shorter string');
testvalueconv('AB');
testvalueconv('ABCDEFG');
testvalueconv(car4_1);
testvalueconv(car6_1);
getmem(pc,256);
pc:='Long Test';
{$ifdef FPC this is not allowed in BP !}
testvalueconv(pc);
{$endif def FPC this is not allowed in BP !}
testconstconv('AB');
{$ifdef test_known_problems}
testconstconv('ABCDEFG');
{$endif}
testconstconv(st4_1);
{$ifdef test_known_problems}
testconstconv(cst6_2);
{$endif}
{$ifdef FPC this is not allowed in BP !}
{$ifdef test_known_problems}
testconstconv(pc);
{$endif}
{$endif def FPC this is not allowed in BP !}
testvarconv(st4_2);
testvarconv(cst4_1);
{$ifdef FPC this is not allowed in BP !}
{$ifdef test_known_problems}
testvarconv(st6_1);
testvarconv(cst8_1);
{$endif}
{$endif def FPC this is not allowed in BP !}
{ testvarconv(pc); this one fails at compilation }
testvarconv2(st4_2);
testvarconv2(cst4_1);
{$ifdef FPC this is not allowed in BP !}
{$ifdef test_known_problems}
testvarconv2(st6_1);
testvarconv2(cst8_1);
{$endif}
{$endif def FPC this is not allowed in BP !}
if has_errors then
begin
Writeln('There are still problems with arrays of char');
Halt(1);
end;
end.
|
