paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-12 09:49:11 +02:00
Code Issues Packages Projects Releases Wiki Activity

* updated for new refcnt

Browse Source
This commit is contained in:
peter 2004-07-13 14:40:34 +00:00
parent f32221853d
commit 94aebf36f1
3 changed files with 58 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
tests/test/tstring6.pp
View File

@ -1,12 +1,14 @@
{ %VERSION=1.1 } { %VERSION=1.1 }
Program widetest; Program widetest;
{$ifndef fpc} Function MemUsed : Longint;
Function Memavail : Longint;
begin begin
Result:=0; {$ifdef fpc}
end; MemUsed:=Heapsize-Memavail;
{$else}
MemUsed:=0;
{$endif} {$endif}
end;
{ ------------------------------------------------------------------- { -------------------------------------------------------------------
General stuff General stuff
@ -15,8 +17,8 @@ end;
Procedure DoMem (Var StartMem : Longint); Procedure DoMem (Var StartMem : Longint);
begin begin
Writeln ('Lost ',StartMem-Memavail,' Bytes.'); Writeln ('Lost ',StartMem-MemUsed,' Bytes.');
StartMem:=MemAvail; StartMem:=MemUsed;
end; end;
Procedure DoRef (P : Pointer); Procedure DoRef (P : Pointer);
@ -27,11 +29,17 @@ begin
If P=Nil then If P=Nil then
Writeln ('(Ref : Empty string)') Writeln ('(Ref : Empty string)')
else else
begin
{$ifdef fpc} {$ifdef fpc}
Writeln (' (Ref: ',Plongint(Longint(P)-4)^,',Len: ',PLongint(Longint(P)-8)^,')'); {$if defined(ver1_0) or defined(ver1_9_4)}
Writeln (' (Ref: ',Plongint(Longint(P)-4)^,',Len: ',PLongint(Longint(P)-8)^,')');
{$else}
Writeln (' (Ref: ',Plongint(Longint(P)-8)^,',Len: ',PLongint(Longint(P)-4)^,')');
{$endif}
{$else} {$else}
Writeln (' (Ref: ',Plongint(Longint(P)-8)^,',Len: ',PLongint(Longint(P)-4)^ div sizeof(WideChar),')'); Writeln (' (Ref: ',Plongint(Longint(P)-8)^,',Len: ',PLongint(Longint(P)-4)^ div sizeof(WideChar),')');
{$endif} {$endif}
end;
end; end;
{ ------------------------------------------------------------------- { -------------------------------------------------------------------
@ -124,7 +132,7 @@ Var S : WideString;
Mem : Longint; Mem : Longint;
begin begin
Mem:=MemAvail; Mem:=MemUsed;
S :='This is another WideString'; S :='This is another WideString';
Writeln ('Calling testvalparam with "',s,'"'); Writeln ('Calling testvalparam with "',s,'"');
testvalparam (s); testvalparam (s);
@ -321,7 +329,7 @@ Var I : Integer;
mem : Longint; mem : Longint;
begin begin
mem:=memavail; mem:=MemUsed;
S3 := 'ABCDEF'; S3 := 'ABCDEF';
Write ('S1+S2=S3 :'); Write ('S1+S2=S3 :');
If S1+S2=S3 then writeln (ok) else writeln (nok); If S1+S2=S3 then writeln (ok) else writeln (nok);
@ -364,7 +372,7 @@ Var S,T : WideString;
Co : Comp; Co : Comp;
TempMem:Longint; TempMem:Longint;
begin begin
TempMem:=Memavail; TempMem:=MemUsed;
S:='ABCDEF'; S:='ABCDEF';
Write ('S = "',S,'"');Doref(Pointer(S)); Write ('S = "',S,'"');Doref(Pointer(S));
T:=Copy(S,1,3); T:=Copy(S,1,3);
@ -451,8 +459,8 @@ end;
Var GlobalStartMem,StartMem : Longint; Var GlobalStartMem,StartMem : Longint;
begin begin
GlobalStartMem:=MemAvail; GlobalStartMem:=MemUsed;
StartMem:=MemAvail; StartMem:=MemUsed;
Writeln ('Testing Initialize/Finalize.'); Writeln ('Testing Initialize/Finalize.');
TestInitFinal; TestInitFinal;
Write ('End of Initialize/finalize test : ');DoMem(StartMem); Write ('End of Initialize/finalize test : ');DoMem(StartMem);

39
tests/webtbs/tw1677.pp
View File

@ -3,11 +3,39 @@
{ e-mail: anders.lindeberg@telia.com } { e-mail: anders.lindeberg@telia.com }
program test; program test;
type trec = record i:integer; s:ansistring end; type trec = record i:integer; s:ansistring end;
procedure RefCount(const s : ansistring;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}
{$if defined(ver1_0) or defined(ver1_9_4)}
rc:=(p-1)^;
{$else}
rc:=plongint(pchar(p)-8)^;
{$endif}
{$else}
rc:=plongint(pchar(p)-8)^;
{$endif}
writeln('Ref count is ',rc,' expected ',expect);
if rc<>expect then
halt(1);
end;
procedure p1(const r:trec); procedure p1(const r:trec);
begin begin
end; end;
procedure p2(r:trec); procedure p2(r:trec);
begin begin
end; end;
@ -24,16 +52,13 @@ begin
s:=chr(ord('A')+random(26)); s:=chr(ord('A')+random(26));
r.s:=s; r.s:=s;
writeln('init'); writeln('init');
if plongint(pointer(s)-4)^<>3 then RefCount(s,3);
halt(1);
writeln('p1()'); writeln('p1()');
p1(r); p1(r);
if plongint(pointer(s)-4)^<>3 then RefCount(s,3);
halt(1);
writeln('p2()'); writeln('p2()');
p2(r); p2(r);
if plongint(pointer(s)-4)^<>3 then RefCount(s,3);
halt(1);
writeln('ok'); writeln('ok');
end. end.

6
tests/webtbs/tw2911.pp
View File

@ -33,9 +33,13 @@ begin
then writeln('Nil string.') then writeln('Nil string.')
else else
{$ifdef fpc} {$ifdef fpc}
{$if defined(ver1_0) or defined(ver1_9_4)}
rc:=(p-1)^; rc:=(p-1)^;
{$else}
rc:=plongint(pchar(p)-8)^;
{$endif}
{$else} {$else}
rc:=plongint(pchar(p)-8)^); rc:=plongint(pchar(p)-8)^;
{$endif} {$endif}
writeln('Ref count is ',rc,' expected ',expect); writeln('Ref count is ',rc,' expected ',expect);
if rc<>expect then if rc<>expect then