+tbs271.pp to tbs0279.pp

This commit is contained in:
pierre 1999-12-02 09:26:06 +00:00
parent 3909f4bab8
commit c0419fc706
10 changed files with 244 additions and 0 deletions

36
tests/tbf0272.pp Normal file
View File

@ -0,0 +1,36 @@
program test_const_string;
const
conststring = 'Constant string';
function astring(s :string) : string;
begin
astring:='Test string'+s;
end;
procedure testvar(var s : string);
begin
writeln('testvar s is "',s,'"');
end;
procedure testconst(const s : string);
begin
writeln('testconst s is "',s,'"');
end;
procedure testvalue(s : string);
begin
writeln('testvalue s is "',s,'"');
end;
const
s : string = 'test';
begin
testvalue(astring('e'));
testconst(astring(s));
testconst(conststring);
testvar(conststring);{ refused a compile time }
end.

31
tests/tbs0271.pp Normal file
View File

@ -0,0 +1,31 @@
{$mode fpc}
type
tproc = procedure;
procedure proc1;
begin
end;
var
_copyscan : tproc;
procedure setproc;
begin
_copyscan := @proc1;
end;
procedure testproc;
begin
if not (_copyscan=@proc1) then
begin
Writeln(' Problem procvar equality');
Halt(1);
end
else
Writeln(' No problem with procedure equality');
end;
begin
setproc;
testproc;
end.

33
tests/tbs0272.pp Normal file
View File

@ -0,0 +1,33 @@
program test_const_string;
function astring(s :string) : string;
begin
astring:='Test string'+s;
end;
procedure testvar(var s : string);
begin
writeln('testvar s is "',s,'"');
end;
procedure testconst(const s : string);
begin
writeln('testconst s is "',s,'"');
end;
procedure testvalue(s : string);
begin
writeln('testvalue s is "',s,'"');
end;
const
s : string = 'test';
conststr = 'Const test';
begin
testvalue(astring('e'));
testconst(astring(s));
testconst(conststr);
end.

13
tests/tbs0273.pp Normal file
View File

@ -0,0 +1,13 @@
Program CharArr;
Var CharArray : Array[1..4] Of Char;
S : String;
Begin
CharArray:='BUG?';
S:=CharArray;
WriteLn(S); { * This is O.K. * }
WriteLn(CharArray); { * GENERAL PROTECTION FAULT. * }
End.

13
tests/tbs0274.pp Normal file
View File

@ -0,0 +1,13 @@
type
proc=procedure(a:longint);
procedure prc(a:longint);
begin
end;
var
p : proc;
begin
p:=@prc;
p:=@(prc); { should this be allowed ? }
end.

5
tests/tbs0275.pp Normal file
View File

@ -0,0 +1,5 @@
var
d : single;
begin
writeln(longint(d));
end.

46
tests/tbs0276.pp Normal file
View File

@ -0,0 +1,46 @@
{$asmmode intel}
type
trec = record
ypos,
xpos : longint;
end;
z80cont = record
dummy : longint;
page: array [0..11,0..16383] of byte;
end;
var
rec : tRec;
myz80 : z80cont;
error : boolean;
test : byte;
begin
error:=false;
test:=23;
rec.xpos:=1;
myz80.page[0,5]:=15;
asm
lea edi, Rec
cmp byte ptr [edi+tRec.Xpos], 1
jne @error
cmp byte ptr [edi].trec.Xpos, 1
jne @error
mov ecx, 5
mov dh,byte ptr myz80.page[ecx]
cmp dh,15
jne @error
mov byte ptr myz80.page[ecx],51
jmp @noerror
@error:
mov byte ptr error,1
@noerror:
end;
if error or (test<>23) or (myz80.page[0,5]<>51) then
begin
Writeln('Error in assembler code generation');
Halt(1);
end
else
Writeln('Correct assembler generated');
end.

5
tests/tbs0277.pp Normal file
View File

@ -0,0 +1,5 @@
program bug0277;
const test_byte=pchar(1);
begin
writeln('Hello world');
end.

29
tests/tbs0278.pp Normal file
View File

@ -0,0 +1,29 @@
{$ifdef fpc}{$mode tp}{$endif}
unit tbs0278;
interface
{
a string constant within $IFDEF that
contains "(*" causes an error;
compile it with "ppc386 test -So" or "-Sd"
}
var
c : char;
{$IFDEF not_defined}
const
c = 'b''(*
{ $else}
var
c : char;
{$ENDIF}
implementation
end.

33
tests/tbs0279.pp Normal file
View File

@ -0,0 +1,33 @@
{$H+}
Program AnsiTest;
Type
PS=^String;
procedure test;
var
P:PS;
Begin
New(P);
P^:='';
P^:=P^+'BLAH';
P^:=P^+' '+P^;
Writeln(P^);
Dispose(P);
end;
var
membefore : longint;
begin
membefore:=memavail;
test;
if membefore<>memavail then
begin
Writeln('Memory hole using pointers to ansi strings');
Halt(1);
end
else
Writeln('No memory hole with pointers to ansi strings');
end.