paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-17 13:39:36 +02:00
Code Issues Packages Projects Releases Wiki Activity

several modifications

Browse Source
This commit is contained in:
pierre 1999-01-19 17:34:01 +00:00
parent 34450917f1
commit 2896a491d7
11 changed files with 87 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
tests/makefile
View File

@ -13,7 +13,8 @@ ifdef DJGPP
EXEEXT=.exe
getreturncode :
redir -e $(FILE).log -o $(FILE).log getret $(COMMAND)
pcs > $(FILE).log
redir -ea $(FILE).log -oa $(FILE).log getret $(COMMAND)
cp retcode $(FILE).$(RESEXT)
else
@ -220,7 +221,10 @@ info :
@echo run \'make tesiexec\' to test executables
@echo that require interactive mode
# $Log$
# Revision 1.10 1999-01-15 17:41:58 pierre
# Revision 1.11 1999-01-19 17:34:01 pierre
# several modifications
#
# Revision 1.10 1999/01/15 17:41:58 pierre
# + new bugs converted
#
# Revision 1.9 1998/11/10 11:13:07 pierre

0
tests/tbs0136.pp → tests/tbf0136.pp
View File

0
tests/tbs0151.pp → tests/tbf0151.pp
View File

31
tests/tbs0075.pp
View File

@ -1,31 +0,0 @@
Unit tbs0075;
Interface
Procedure MyTest;Far; { IMPLEMENTATION expected error. }
{ Further information: NEAR IS NOT ALLOWED IN BORLAND PASCAL }
{ Therefore the bugfix should only be for the FAR keyword. }
Procedure MySecondTest;
Implementation
{ near and far are not allowed here, but maybe we don't care since they are ignored by }
{ FPC. }
Procedure MyTest;
Begin
end;
Procedure MySecondTest;Far;Forward;
Procedure MySecondTest;Far;
Begin
end;
end.

2
tests/tbs0150.pp
View File

@ -1,4 +1,4 @@
programs bug0150;
program bug0150;
{
bug to show that there is no assert() macro and directive
}

11
tests/tbs0155.pp
View File

@ -1,11 +0,0 @@
function asmstr:string;assembler;
asm
movl __RESULT,%edi
movl $0x4101,%al
stosw
end;
begin
writeln(asmstr);
end;

11
tests/tbs0161.pp
View File

@ -1,11 +0,0 @@
Program tbs0161;
{the following program should give a syntax error, but causes an internal error}
const s = [1,2,3,4,5];
var b: Byte;
Begin
If b in [s] then;
End.

8
tests/tbs0191.pp
View File

@ -6,7 +6,6 @@ type
const
s : string = 'test';
pc : pchar = @s[1];
cfg : array[1..2] of trec=(
(a:1;b:2),
@ -16,5 +15,12 @@ const
l : ^longint = @cfg[1].b; { l^ should be 2 }
pc : pchar = @s[1];
begin
if (l^<>2) or (pc[1]<>'t') then
Begin
Writeln('Wrong code genrated');
RunError(1);
End;
end.

13
tests/tbs0196.pp Normal file
View File

@ -0,0 +1,13 @@
{$OPT= -So}
Unit tbs0196;
interface
function a : integer;
implementation
function a;
begin
a:=1;
end;
end.

24
tests/tbs0199.pp Normal file
View File

@ -0,0 +1,24 @@
PROGRAM PRTest;
TYPE
ptRec = ^tRec;
tRec = Record
D : DWORD;
END;
VAR
pR1, pR2 : ptRec;
BEGIN
GetMem(pR1, SizeOf(tRec));
GetMem(pR2, SizeOf(tRec));
pR1^.D := 10;
Move(pR1^,pR2^,SizeOf(tRec));
WriteLn(pR1^.D:16,pR2^.D:16);
pR1^.D := 1;
pR2^.D := pR1^.D*2; { THE BUG IS HERE }
WriteLn(pR1^.D:16,pR2^.D:16);
if (pR1^.D<>1) or (pR2^.D<>2) then
Halt(1);
END.

36
tests/tbs0201.pp Normal file
View File

@ -0,0 +1,36 @@
{ $OPT= -Ratt }
program bug0201;
type rec = record
a : DWord;
b : Word;
end;
function x(r1 : rec; r2 : rec; var r3 : rec); assembler;
asm
movl r3, %edi
movl r1.a, %eax
addl r2.a, %eax
movl %eax, rec.a(%edi)
movw r1.b, %cx
addw r2.b, %cx
movw %cx, rec.b(%edi)
end;
var r1, r2, r3 : rec;
begin
r1.a := 100; r1.b := 200;
r2.a := 300; r2.b := 400;
x(r1, r2, r3);
Writeln(r3.a, ' ', r3.b);
if (r3.a<>400) or (r3.b<>600) then
begin
Writeln('Error in assembler code');
Halt(1);
end;
end.