mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-12 20:29:23 +02:00
+tbs271.pp to tbs0279.pp
This commit is contained in:
parent
3909f4bab8
commit
c0419fc706
36
tests/tbf0272.pp
Normal file
36
tests/tbf0272.pp
Normal 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
31
tests/tbs0271.pp
Normal 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
33
tests/tbs0272.pp
Normal 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
13
tests/tbs0273.pp
Normal 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
13
tests/tbs0274.pp
Normal 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
5
tests/tbs0275.pp
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
var
|
||||||
|
d : single;
|
||||||
|
begin
|
||||||
|
writeln(longint(d));
|
||||||
|
end.
|
46
tests/tbs0276.pp
Normal file
46
tests/tbs0276.pp
Normal 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
5
tests/tbs0277.pp
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
program bug0277;
|
||||||
|
const test_byte=pchar(1);
|
||||||
|
begin
|
||||||
|
writeln('Hello world');
|
||||||
|
end.
|
29
tests/tbs0278.pp
Normal file
29
tests/tbs0278.pp
Normal 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
33
tests/tbs0279.pp
Normal 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.
|
||||||
|
|
Loading…
Reference in New Issue
Block a user