mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-12 22:14:25 +02:00
* new bugs
This commit is contained in:
parent
ac1332a388
commit
0f17fe1bd3
20
tests/webtbs/tw2897.pp
Normal file
20
tests/webtbs/tw2897.pp
Normal file
@ -0,0 +1,20 @@
|
|||||||
|
{ Source provided for Free Pascal Bug Report 2897 }
|
||||||
|
{ Submitted by "C Western" on 2004-01-17 }
|
||||||
|
{ e-mail: mftq75@dsl.pipex.com }
|
||||||
|
program stackerr;
|
||||||
|
|
||||||
|
{$S+}
|
||||||
|
|
||||||
|
procedure Show(v: Integer);
|
||||||
|
begin
|
||||||
|
WriteLn(v);
|
||||||
|
if v<>27 then
|
||||||
|
begin
|
||||||
|
writeln('Error!');
|
||||||
|
halt(1);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
begin
|
||||||
|
Show(27)
|
||||||
|
end.
|
31
tests/webtbs/tw2899.pp
Normal file
31
tests/webtbs/tw2899.pp
Normal file
@ -0,0 +1,31 @@
|
|||||||
|
{ Source provided for Free Pascal Bug Report 2899 }
|
||||||
|
{ Submitted by "Mattias Gaertner" on 2004-01-17 }
|
||||||
|
{ e-mail: mattias@freepascal.org }
|
||||||
|
program StringCallByRef;
|
||||||
|
|
||||||
|
{$ifdef fpc}{$mode objfpc}{$H+}{$endif}
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils;
|
||||||
|
|
||||||
|
procedure DoSomething(const AString: string);
|
||||||
|
|
||||||
|
procedure NestedProc(var Dummy: string);
|
||||||
|
begin
|
||||||
|
Dummy:=Dummy; // dummy statement, no change
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
s: String;
|
||||||
|
begin
|
||||||
|
s:=copy(AString,5,11);
|
||||||
|
writeln('Before NestedProc: "',s,'"');
|
||||||
|
NestedProc(s);
|
||||||
|
writeln('After NestedProc: "',s,'"'); // s is now emtpy
|
||||||
|
if s<>'WhatAStrangeBug' then
|
||||||
|
halt(1);
|
||||||
|
end;
|
||||||
|
|
||||||
|
begin
|
||||||
|
DoSomething('WhatAStrangeBug');
|
||||||
|
end.
|
64
tests/webtbs/tw2911.pp
Normal file
64
tests/webtbs/tw2911.pp
Normal file
@ -0,0 +1,64 @@
|
|||||||
|
{ Source provided for Free Pascal Bug Report 2911 }
|
||||||
|
{ Submitted by "Chris Hilder" on 2004-01-19 }
|
||||||
|
{ e-mail: cj.hilder@astronomyinyourhands.com }
|
||||||
|
program bug_demo;
|
||||||
|
{$LONGSTRINGS ON}
|
||||||
|
|
||||||
|
{$ifdef fpc}{$Mode objfpc}{$endif}
|
||||||
|
|
||||||
|
type
|
||||||
|
RecordWithStrings =
|
||||||
|
record
|
||||||
|
one,
|
||||||
|
two : string;
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
onestring,
|
||||||
|
twostring : string;
|
||||||
|
ARecordWithStrings : RecordWithStrings;
|
||||||
|
|
||||||
|
procedure RefCount(const s : string;expect:longint);
|
||||||
|
type
|
||||||
|
PLongint = ^Longint;
|
||||||
|
var
|
||||||
|
P : PLongint;
|
||||||
|
rc : longint;
|
||||||
|
begin
|
||||||
|
P := PLongint(s);
|
||||||
|
rc:=0;
|
||||||
|
if (p = nil)
|
||||||
|
then writeln('Nil string.')
|
||||||
|
else
|
||||||
|
{$ifdef fpc}
|
||||||
|
rc:=(p-1)^;
|
||||||
|
{$else}
|
||||||
|
rc:=plongint(pchar(p)-8)^);
|
||||||
|
{$endif}
|
||||||
|
writeln('Ref count is ',rc,' expected ',expect);
|
||||||
|
if rc<>expect then
|
||||||
|
halt(1);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function FunctionResultIsRecord(a : RecordWithStrings) : RecordWithStrings;
|
||||||
|
begin
|
||||||
|
result := a;
|
||||||
|
end;
|
||||||
|
|
||||||
|
begin
|
||||||
|
writeln('All reference counts should be 1 for the following...');
|
||||||
|
onestring := 'one';
|
||||||
|
twostring := 'two';
|
||||||
|
ARecordWithStrings.one := onestring + twostring;
|
||||||
|
twostring := onestring + twostring;
|
||||||
|
RefCount(ARecordWithStrings.one,1);
|
||||||
|
ARecordWithStrings := FunctionResultIsRecord(ARecordWithStrings);
|
||||||
|
twostring := onestring + twostring;
|
||||||
|
RefCount(ARecordWithStrings.one,2);
|
||||||
|
ARecordWithStrings := FunctionResultIsRecord(ARecordWithStrings);
|
||||||
|
twostring := onestring + twostring;
|
||||||
|
RefCount(ARecordWithStrings.one,3);
|
||||||
|
ARecordWithStrings := FunctionResultIsRecord(ARecordWithStrings);
|
||||||
|
twostring := onestring + twostring;
|
||||||
|
RefCount(ARecordWithStrings.one,4);
|
||||||
|
end.
|
Loading…
Reference in New Issue
Block a user