paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-06 10:07:54 +02:00
Code Issues Packages Projects Releases Wiki Activity

* synchronize with trunk

Browse Source 
git-svn-id: branches/z80@44503 -
This commit is contained in:
nickysn 2020-04-01 22:43:55 +00:00
commit 50e5b07568
25 changed files with 493 additions and 123 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -16499,6 +16499,7 @@ tests/webtbf/uw8738b.pas svneol=native#text/plain
tests/webtbs/Integer.ns.pp svneol=native#text/pascal
tests/webtbs/Integer.pp svneol=native#text/pascal
tests/webtbs/tu2002.pp svneol=native#text/plain
tests/webtbs/tw0035022.pp svneol=native#text/plain
tests/webtbs/tw0555.pp svneol=native#text/plain
tests/webtbs/tw0630.pp svneol=native#text/plain
tests/webtbs/tw0701a.pp svneol=native#text/plain

8
compiler/options.pas
View File

@ -4248,8 +4248,7 @@ begin
((target_info.system in [system_arm_wince,system_arm_gba,
system_m68k_amiga,system_m68k_atari,
system_arm_nds,system_arm_embedded,
system_riscv32_embedded,system_riscv64_embedded,system_xtensa_embedded,
system_xtensa_freertos])
system_riscv32_embedded,system_riscv64_embedded,system_xtensa_embedded])
{$ifdef arm}
or (target_info.abi=abi_eabi)
{$endif arm}
@ -4284,6 +4283,11 @@ begin
end;
{$endif i386}
{$ifdef xtensa}
if not(option.FPUSetExplicitly) then
init_settings.fputype:=embedded_controllers[init_settings.controllertype].fputype;
{$endif xtensa}
{$ifdef arm}
case target_info.system of
system_arm_darwin:

2
compiler/systems/i_freertos.pas
View File

@ -714,7 +714,7 @@ unit i_freertos;
first_parm_offset : 8;
stacksize : 65536;
stackalign : 16;
abi : abi_default;
abi : abi_xtensa_windowed;
llvmdatalayout : 'e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32-S32';
);

7
compiler/xtensa/cgcpu.pas
View File

@ -633,8 +633,11 @@ implementation
end
else
begin
{ spill area }
inc(localsize,max(txtensaprocinfo(current_procinfo).maxcall,4)*4);
{ default spill area }
inc(localsize,4*4);
{ additional spill area? }
if pi_do_call in current_procinfo.flags then
inc(localsize,txtensaprocinfo(current_procinfo).maxcall*4);
localsize:=align(localsize,current_settings.alignment.localalignmax);
end;

19
compiler/xtensa/cpupi.pas
View File

@ -65,7 +65,7 @@ unit cpupi;
constructor txtensaprocinfo.create(aparent: tprocinfo);
begin
inherited create(aparent);
maxpushedparasize := 0;
maxpushedparasize:=0;
if target_info.abi=abi_xtensa_windowed then
begin
callins:=A_CALL8;
@ -92,23 +92,15 @@ unit cpupi;
localsize : aint;
i : longint;
begin
if (po_nostackframe in procdef.procoptions) then
begin
{ maxpushedparasize sghould be zero,
if not we will get an error later. }
tg.setfirsttemp(maxpushedparasize);
exit;
end;
tg.setfirsttemp(maxpushedparasize);
if tg.direction = -1 then
tg.setfirsttemp(-(1+12)*4)
else
tg.setfirsttemp(maxpushedparasize);
if po_nostackframe in procdef.procoptions then
exit;
{ estimate stack frame size }
if pi_estimatestacksize in flags then
begin
stackframesize:=maxpushedparasize+32;
stackframesize:=maxpushedparasize;
localsize:=0;
for i:=0 to procdef.localst.SymList.Count-1 do
if tsym(procdef.localst.SymList[i]).typ=localvarsym then
@ -126,7 +118,6 @@ unit cpupi;
else
inc(localsize,tabstractnormalvarsym(procdef.parast.SymList[i]).getsize);
end;
inc(stackframesize,localsize);
if pi_needs_implicit_finally in flags then

48
compiler/xtensa/rxtensacon.inc
View File

@ -16,19 +16,35 @@ NR_A12 = tregister($0100000c);
NR_A13 = tregister($0100000d);
NR_A14 = tregister($0100000e);
NR_A15 = tregister($0100000f);
NR_F0 = tregister($01000000);
NR_F1 = tregister($01000001);
NR_F2 = tregister($01000002);
NR_F3 = tregister($01000003);
NR_F4 = tregister($01000004);
NR_F5 = tregister($01000005);
NR_F6 = tregister($01000006);
NR_F7 = tregister($01000007);
NR_F8 = tregister($01000008);
NR_F9 = tregister($01000009);
NR_F10 = tregister($0100000f);
NR_F11 = tregister($0100000b);
NR_F12 = tregister($0100000c);
NR_F13 = tregister($0100000d);
NR_F14 = tregister($0100000e);
NR_F15 = tregister($0100000f);
NR_F0 = tregister($02000000);
NR_F1 = tregister($02000001);
NR_F2 = tregister($02000002);
NR_F3 = tregister($02000003);
NR_F4 = tregister($02000004);
NR_F5 = tregister($02000005);
NR_F6 = tregister($02000006);
NR_F7 = tregister($02000007);
NR_F8 = tregister($02000008);
NR_F9 = tregister($02000009);
NR_F10 = tregister($0200000f);
NR_F11 = tregister($0200000b);
NR_F12 = tregister($0200000c);
NR_F13 = tregister($0200000d);
NR_F14 = tregister($0200000e);
NR_F15 = tregister($0200000f);
NR_B0 = tregister($05000000);
NR_B1 = tregister($05000001);
NR_B2 = tregister($05000002);
NR_B3 = tregister($05000003);
NR_B4 = tregister($05000004);
NR_B5 = tregister($05000005);
NR_B6 = tregister($05000006);
NR_B7 = tregister($05000007);
NR_B8 = tregister($05000008);
NR_B9 = tregister($05000009);
NR_B10 = tregister($0500000b);
NR_B11 = tregister($0500000b);
NR_B12 = tregister($0500000c);
NR_B13 = tregister($0500000d);
NR_B14 = tregister($0500000e);
NR_B15 = tregister($0500000b);

16
compiler/xtensa/rxtensadwa.inc
View File

@ -31,4 +31,20 @@
12,
13,
14,
15,
0,
1,
2,
3,
4,
5,
6,
7,
8,
9,
10,
11,
12,
13,
14,
15

2
compiler/xtensa/rxtensanor.inc
View File

@ -1,2 +1,2 @@
{ don't edit, this file is generated from xtensareg.dat }
33
49

48
compiler/xtensa/rxtensanum.inc
View File

@ -16,19 +16,35 @@ tregister($0100000c),
tregister($0100000d),
tregister($0100000e),
tregister($0100000f),
tregister($01000000),
tregister($01000001),
tregister($01000002),
tregister($01000003),
tregister($01000004),
tregister($01000005),
tregister($01000006),
tregister($01000007),
tregister($01000008),
tregister($01000009),
tregister($0100000f),
tregister($0100000b),
tregister($0100000c),
tregister($0100000d),
tregister($0100000e),
tregister($0100000f)
tregister($02000000),
tregister($02000001),
tregister($02000002),
tregister($02000003),
tregister($02000004),
tregister($02000005),
tregister($02000006),
tregister($02000007),
tregister($02000008),
tregister($02000009),
tregister($0200000f),
tregister($0200000b),
tregister($0200000c),
tregister($0200000d),
tregister($0200000e),
tregister($0200000f),
tregister($05000000),
tregister($05000001),
tregister($05000002),
tregister($05000003),
tregister($05000004),
tregister($05000005),
tregister($05000006),
tregister($05000007),
tregister($05000008),
tregister($05000009),
tregister($0500000b),
tregister($0500000b),
tregister($0500000c),
tregister($0500000d),
tregister($0500000e),
tregister($0500000b)

46
compiler/xtensa/rxtensarni.inc
View File

@ -1,34 +1,50 @@
{ don't edit, this file is generated from xtensareg.dat }
0,
1,
17,
2,
18,
3,
19,
4,
20,
5,
21,
6,
22,
7,
23,
8,
24,
9,
25,
10,
26,
11,
12,
28,
13,
29,
14,
30,
15,
31,
16,
17,
18,
19,
20,
21,
22,
23,
24,
25,
26,
28,
29,
30,
31,
27,
32
32,
33,
34,
35,
36,
37,
38,
39,
40,
41,
42,
43,
44,
48,
45,
46,
47

16
compiler/xtensa/rxtensasri.inc
View File

@ -16,6 +16,22 @@
8,
9,
10,
33,
34,
43,
44,
45,
46,
47,
48,
35,
36,
37,
38,
39,
40,
41,
42,
17,
18,
27,

16
compiler/xtensa/rxtensasta.inc
View File

@ -31,4 +31,20 @@
12,
13,
14,
15,
0,
1,
2,
3,
4,
5,
6,
7,
8,
9,
10,
11,
12,
13,
14,
15

18
compiler/xtensa/rxtensastd.inc
View File

@ -31,4 +31,20 @@
'f12',
'f13',
'f14',
'f15'
'f15',
'b0',
'b1',
'b2',
'b3',
'b4',
'b5',
'b6',
'b7',
'b8',
'b9',
'b10',
'b11',
'b12',
'b13',
'b14',
'b15'

16
compiler/xtensa/rxtensasup.inc
View File

@ -32,3 +32,19 @@ RS_F12 = $0c;
RS_F13 = $0d;
RS_F14 = $0e;
RS_F15 = $0f;
RS_B0 = $00;
RS_B1 = $01;
RS_B2 = $02;
RS_B3 = $03;
RS_B4 = $04;
RS_B5 = $05;
RS_B6 = $06;
RS_B7 = $07;
RS_B8 = $08;
RS_B9 = $09;
RS_B10 = $0b;
RS_B11 = $0b;
RS_B12 = $0c;
RS_B13 = $0d;
RS_B14 = $0e;
RS_B15 = $0b;

7
compiler/xtensa/xtensaatt.inc
View File

@ -2,6 +2,7 @@
'none',
'abs',
'add',
'add.s',
'addi',
'addmi',
'and',
@ -28,9 +29,14 @@
'mov.s',
'movnez',
'movi',
'mul.s',
'mull',
'neg',
'neg.s',
'nop',
'oeq.s',
'ole.s',
'olt.s',
'or',
'ret',
'retw',
@ -47,6 +53,7 @@
'ssl',
'ssr',
'sub',
'sub.s',
'xor'
);

7
compiler/xtensa/xtensaop.inc
View File

@ -2,6 +2,7 @@
A_NONE,
A_ABS,
A_ADD,
A_ADD_S,
A_ADDI,
A_ADDMI,
A_AND,
@ -28,9 +29,14 @@ A_MOV,
A_MOV_S,
A_MOVNEZ,
A_MOVI,
A_MUL_S,
A_MULL,
A_NEG,
A_NEG_S,
A_NOP,
A_OEQ_S,
A_OLE_S,
A_OLT_S,
A_OR,
A_RET,
A_RETW,
@ -47,6 +53,7 @@ A_SSI,
A_SSL,
A_SSR,
A_SUB,
A_SUB_S,
A_XOR
);

50
compiler/xtensa/xtensareg.dat
View File

@ -24,22 +24,38 @@ A14,$01,$00,$0e,a14,14,14
A15,$01,$00,$0f,a15,15,15
; Floating point registers
F0,$01,$00,$00,f0,0,0
F1,$01,$00,$01,f1,1,1
F2,$01,$00,$02,f2,2,2
F3,$01,$00,$03,f3,3,3
F4,$01,$00,$04,f4,4,4
F5,$01,$00,$05,f5,5,5
F6,$01,$00,$06,f6,6,6
F7,$01,$00,$07,f7,7,7
F8,$01,$00,$08,f8,8,8
F9,$01,$00,$09,f9,9,9
F10,$01,$00,$0f,f10,10,10
F11,$01,$00,$0b,f11,11,11
F12,$01,$00,$0c,f12,12,12
F13,$01,$00,$0d,f13,13,13
F14,$01,$00,$0e,f14,14,14
F15,$01,$00,$0f,f15,15,15
F0,$02,$00,$00,f0,0,0
F1,$02,$00,$01,f1,1,1
F2,$02,$00,$02,f2,2,2
F3,$02,$00,$03,f3,3,3
F4,$02,$00,$04,f4,4,4
F5,$02,$00,$05,f5,5,5
F6,$02,$00,$06,f6,6,6
F7,$02,$00,$07,f7,7,7
F8,$02,$00,$08,f8,8,8
F9,$02,$00,$09,f9,9,9
F10,$02,$00,$0f,f10,10,10
F11,$02,$00,$0b,f11,11,11
F12,$02,$00,$0c,f12,12,12
F13,$02,$00,$0d,f13,13,13
F14,$02,$00,$0e,f14,14,14
F15,$02,$00,$0f,f15,15,15
; Boolean registers
B0,$05,$00,$00,b0,0,0
B1,$05,$00,$01,b1,1,1
B2,$05,$00,$02,b2,2,2
B3,$05,$00,$03,b3,3,3
B4,$05,$00,$04,b4,4,4
B5,$05,$00,$05,b5,5,5
B6,$05,$00,$06,b6,6,6
B7,$05,$00,$07,b7,7,7
B8,$05,$00,$08,b8,8,8
B9,$05,$00,$09,b9,9,9
B10,$05,$00,$0b,b10,10,10
B11,$05,$00,$0b,b11,11,11
B12,$05,$00,$0c,b12,12,12
B13,$05,$00,$0d,b13,13,13
B14,$05,$00,$0e,b14,14,14
B15,$05,$00,$0b,b15,15,15

2
packages/fcl-process/src/process.pp
View File

@ -27,7 +27,7 @@ Type
poNoConsole,poNewConsole,
poDefaultErrorMode,poNewProcessGroup,
poDebugProcess,poDebugOnlyThisProcess,
poPassInput);
poPassInput,porunidle);
TShowWindowOptions = (swoNone,swoHIDE,swoMaximize,swoMinimize,swoRestore,swoShow,
swoShowDefault,swoShowMaximized,swoShowMinimized,

2
packages/fcl-process/src/processbody.inc
View File

@ -562,7 +562,7 @@ begin
if assigned(stderr) then
gotoutputstderr:=ReadInputStream(StdErr,StdErrBytesRead,StdErrLength,StdErrString,1);
if not gotoutput and not gotoutputstderr and Assigned(FOnRunCommandEvent) Then
if (porunidle in options) and not gotoutput and not gotoutputstderr and Assigned(FOnRunCommandEvent) Then
FOnRunCommandEvent(self,Nil,RunCommandIdle,'');
end;
// Get left output after end of execution

22
packages/fcl-registry/src/regini.inc
View File

@ -300,18 +300,18 @@ begin
S:=Section;
If (S<>'') and (S[1] = '\') then
Delete(S,1,1);
if CreateSection then
CreateKey('\'+FPath+S);
if Section <> '' then
if CreateSection and (S<>'') then
CreateKey('\'+CurrentPath+'\'+S);
if S <> '' then
k:=GetKey('\'+CurrentPath+'\'+S)
else
k:=GetKey('\'+CurrentPath);
if k = 0 then
begin
k:=GetKey('\'+FPath+S);
if k = 0 then
begin
Result:=False;
exit;
end;
SetCurrentKey(k);
end;
Result:=False;
exit;
end;
SetCurrentKey(k);
Result:=True;
end;

48
packages/fcl-registry/src/registry.pp
View File

@ -57,6 +57,7 @@ type
fRootKey: HKEY;
fLazyWrite: Boolean;
fCurrentPath: UnicodeString;
function FixPath(APath: UnicodeString): UnicodeString;
function GetLastErrorMsg: string;
function RegMultiSzDataToUnicodeStringArray(U: UnicodeString): TUnicodeStringArray;
function ListToArray(List: TStrings; IsUtf8: Boolean): TUnicodeStringArray;
@ -103,8 +104,8 @@ type
function HasSubKeys: Boolean;
function KeyExists(const Key: UnicodeString): Boolean;
function KeyExists(const Key: String): Boolean;
function LoadKey(const Key, FileName: UnicodeString): Boolean;
function LoadKey(const Key, FileName: String): Boolean;
function LoadKey(const Key, FileName: UnicodeString): Boolean; unimplemented;
function LoadKey(const Key, FileName: String): Boolean; unimplemented;
function OpenKey(const Key: UnicodeString; CanCreate: Boolean): Boolean;
function OpenKey(const Key: String; CanCreate: Boolean): Boolean;
function OpenKeyReadOnly(const Key: UnicodeString): Boolean;
@ -135,10 +136,10 @@ type
function ReadTime(const Name: String): TDateTime;
function RegistryConnect(const UNCName: UnicodeString): Boolean;
function RegistryConnect(const UNCName: String): Boolean;
function ReplaceKey(const Key, FileName, BackUpFileName: UnicodeString): Boolean;
function ReplaceKey(const Key, FileName, BackUpFileName: String): Boolean;
function RestoreKey(const Key, FileName: UnicodeString): Boolean;
function RestoreKey(const Key, FileName: String): Boolean;
function ReplaceKey(const Key, FileName, BackUpFileName: UnicodeString): Boolean; unimplemented;
function ReplaceKey(const Key, FileName, BackUpFileName: String): Boolean; unimplemented;
function RestoreKey(const Key, FileName: UnicodeString): Boolean; unimplemented;
function RestoreKey(const Key, FileName: String): Boolean; unimplemented;
function SaveKey(const Key, FileName: UnicodeString): Boolean;
function SaveKey(const Key, FileName: String): Boolean;
function UnLoadKey(const Key: UnicodeString): Boolean;
@ -153,14 +154,14 @@ type
procedure GetValueNames(Strings: TStrings);
//ToDo
function GetValueNames: TUnicodeStringArray;
procedure MoveKey(const OldName, NewName: UnicodeString; Delete: Boolean);
procedure MoveKey(const OldName, NewName: String; Delete: Boolean);
procedure MoveKey(const OldName, NewName: UnicodeString; Delete: Boolean); unimplemented;
procedure MoveKey(const OldName, NewName: String; Delete: Boolean); unimplemented;
procedure RenameValue(const OldName, NewName: UnicodeString);
procedure RenameValue(const OldName, NewName: String);
procedure WriteCurrency(const Name: UnicodeString; Value: Currency);
procedure WriteCurrency(const Name: String; Value: Currency);
procedure WriteBinaryData(const Name: UnicodeString; var Buffer; BufSize: Integer);
procedure WriteBinaryData(const Name: String; var Buffer; BufSize: Integer);
procedure WriteBinaryData(const Name: UnicodeString; const Buffer; BufSize: Integer);
procedure WriteBinaryData(const Name: String; const Buffer; BufSize: Integer);
procedure WriteBool(const Name: UnicodeString; Value: Boolean);
procedure WriteBool(const Name: String; Value: Boolean);
procedure WriteDate(const Name: UnicodeString; Value: TDateTime);
@ -250,7 +251,7 @@ type
function ReadFloat(const Section, Name: string; Default: Double): Double; override;
function ReadString(const Section, Name, Default: string): string; override;
function ReadTime(const Section, Name: string; Default: TDateTime): TDateTime; override;
function ReadBinaryStream(const Section, Name: string; Value: TStream): Integer; override;
function ReadBinaryStream(const Section, Name: string; Value: TStream): Integer; override; unimplemented;
procedure WriteDate(const Section, Name: string; Value: TDateTime); override;
procedure WriteDateTime(const Section, Name: string; Value: TDateTime); override;
procedure WriteFloat(const Section, Name: string; Value: Double); override;
@ -545,9 +546,7 @@ end;
function TRegistry.ReadDate(const Name: UnicodeString): TDateTime;
begin
Result:=Default(TDateTime);
ReadBinaryData(Name, Result, SizeOf(TDateTime));
Result:=Trunc(Result);
Result:=Trunc(ReadDateTime(Name));
end;
function TRegistry.ReadDate(const Name: String): TDateTime;
@ -632,6 +631,19 @@ begin
ReadStringList(UnicodeString(Name), AList);
end;
function TRegistry.FixPath(APath: UnicodeString): UnicodeString;
const
Delim={$ifdef XMLREG}'/'{$else}'\'{$endif};
begin
//At this point we know the path is valid, since this is only called after OpenKey succeeded
//Just sanitize it
while (Pos(Delim+Delim,APath) > 0) do
APath := UnicodeStringReplace(APath, Delim+Delim,Delim,[rfReplaceAll]);
if (Length(APath) > 1) and (APath[Length(APath)] = Delim) then
System.Delete(APath, Length(APath), 1);
Result := APath;
end;
function TRegistry.RegMultiSzDataToUnicodeStringArray(U: UnicodeString): TUnicodeStringArray;
var
Len, i, p: Integer;
@ -740,9 +752,7 @@ end;
function TRegistry.ReadTime(const Name: UnicodeString): TDateTime;
begin
Result:=Default(TDateTime);
ReadBinaryData(Name, Result, SizeOf(TDateTime));
Result:=Frac(Result);
Result:=Frac(ReadDateTime(Name));
end;
function TRegistry.ReadTime(const Name: String): TDateTime;
@ -780,12 +790,12 @@ begin
Result:=ValueExists(UnicodeString(Name));
end;
procedure TRegistry.WriteBinaryData(const Name: UnicodeString; var Buffer; BufSize: Integer);
procedure TRegistry.WriteBinaryData(const Name: UnicodeString; const Buffer; BufSize: Integer);
begin
PutData(Name, @Buffer, BufSize, rdBinary);
end;
procedure TRegistry.WriteBinaryData(const Name: String; var Buffer;
procedure TRegistry.WriteBinaryData(const Name: String; const Buffer;
BufSize: Integer);
begin
WriteBinaryData(UnicodeString(Name), Buffer, BufSize);

12
packages/fcl-registry/src/winreg.inc
View File

@ -227,8 +227,12 @@ begin
end;
If Result then begin
if RelativeKey(Key) then
S:=CurrentPath + Key
else
begin
if (Key>'') and (CurrentPath>'') and (CurrentPath[Length(CurrentPath)]<>'\') then
S:=CurrentPath + '\' + Key
else
S:=CurrentPath + Key;
end else
S:=u;
ChangeKey(Handle, S);
end;
@ -325,7 +329,7 @@ procedure TRegistry.ChangeKey(Value: HKey; const Path: UnicodeString);
begin
CloseKey;
FCurrentKey:=Value;
FCurrentPath:=Path;
FCurrentPath:=FixPath(Path);
end;
@ -419,8 +423,6 @@ Function TRegistry.SysPutData(const Name: UnicodeString; Buffer: Pointer;
Var
RegDataType: DWORD;
B : Pchar;
S : String;
begin
RegDataType:=RegDataWords[RegData];

1
packages/fcl-registry/src/xmlreg.pp
View File

@ -81,6 +81,7 @@ Type
// These interpret the Data buffer as unicode data
Function GetValueDataUnicode(Name : UnicodeString; Out DataType : TDataType; Var Data; Var DataSize : Integer) : Boolean;
Function SetValueDataUnicode(Name : UnicodeString; DataType : TDataType; Const Data; DataSize : Integer) : Boolean;
Property CurrentKey: UnicodeString read FCurrentKey; //used by TRegistry
Property FileName : String Read FFileName Write SetFileName;
Property RootKey : UnicodeString Read FRootKey Write SetRootkey;
Property AutoFlush : Boolean Read FAutoFlush Write FAutoFlush;

15
packages/fcl-registry/src/xregreg.inc
View File

@ -223,9 +223,22 @@ end;
function TRegistry.OpenKey(const Key: UnicodeString; CanCreate: Boolean): Boolean;
var
S: UnicodeString;
P: SizeInt;
begin
Result:=TXmlRegistry(FSysData).SetKey(Key,CanCreate);
FCurrentKey:=1;
If Result then begin
S:=TXmlRegistry(FSysData).CurrentKey;
if (S>'') then begin
//S starts with RootKey+'/'
P:=Pos('/',S);
if (P>0) then
System.Delete(S,1,P);
end;
ChangeKey(FCurrentKey, S);
end;
end;
function TRegistry.OpenKeyReadOnly(const Key: UnicodeString): Boolean;
@ -266,7 +279,7 @@ end;
procedure TRegistry.ChangeKey(Value: HKey; const Path: UnicodeString);
begin
FCurrentPath:=FixPath(Path);
end;
function TRegistry.GetKeyNames: TUnicodeStringArray;

187
tests/webtbs/tw0035022.pp Normal file
View File

@ -0,0 +1,187 @@
{ %TARGET=win32,win64,wince }
program tw0035022;
{$apptype console}
{$mode objfpc}{$h+}
{$ASSERTIONS ON}
uses
registry, sysutils, classes;
const
ROOT = 'Software';
subFPCREGINITEST = 'FreePascalRegIniTest';
subRegIni = 'RegIni';
subStrings = 'FPCTESTString';
fqFREEPASCALREGINITEST = Root + '\'+ subFPCREGINITEST;
fqFPCTESTRegIni = fqFREEPASCALREGINITEST + '\' + subRegIni;
fqFPCTESTStrings = fqFPCTESTRegIni+'\' + subStrings;
fqWrongFPCTESTStrings = Root + '\' + subStrings;
idString1 = 'String1';
valValue1 = 'Value1';
procedure CheckCreate;
var
Reg: TRegistry;
S, SKey: String;
B: Boolean;
begin
write('CheckCreate: ');
Reg := TRegistry.Create(KEY_READ);
try
Reg.RootKey := HKEY_CURRENT_USER;
SKey := fqFPCTESTRegIni;
B := Reg.OpenKeyReadOnly(SKey);
Assert(B,format('Error: RegOpenKeyReadOnly(''%s'') failed.',[SKey]));
SKey := subStrings;
B := Reg.OpenKeyReadOnly(Skey);
Assert(B,format('Error: RegOpenKeyReadOnly(''%s'') failed.',[fqFPCTESTStrings]));
S := Reg.ReadString(idString1);
Assert(S=valValue1,format('ReadString(''%s''): expected '+'%s, but found: ''%s''',[idString1,valValue1,S]));
Reg.CloseKey;
writeln('OK');
finally
Reg.Free;
end;
end;
procedure FindErroneousEntries;
var
Reg: TRegistry;
B: Boolean;
begin
write('FindErroneousEntries: ');
Reg := TRegistry.Create(KEY_READ);
try
B := Reg.OpenKeyReadOnly(fqWrongFPCTESTStrings);
Reg.CloseKey;
Assert(not B, format('RegOpenKeyReadOnly found %s, which at this point is unexpected.',[fqWrongFPCTESTStrings]));
writeln(' no erroneous entries found (OK).');
finally
Reg.Free;
end;
end;
procedure CreateTestEntries;
var
RegIni: TRegIniFile;
B: Boolean;
function TryOpenKey(Key: String; CanCreate: Boolean): Boolean;
begin
Result := RegIni.OpenKey(Key, CanCreate);
end;
function TryWriteString(Section, Ident, Value: String): Boolean;
begin
Result := False;
try
RegIni.WriteString(Section, Ident, Value);
Result := True;
except
on E: Exception do
end;
end;
begin
write('CreateTestEntries: ');
RegIni := TRegIniFile.Create(Root);
try
Assert(RegIni.CurrentPath=Root,'Expected: CurrenPath='+Root);
B := RegIni.CreateKey(subFPCREGINITEST);
Assert(B,format('Error: CreateKey(''%s'') failed.',[fqFREEPASCALREGINITEST]));
B := TryOpenKey(subFPCREGINITEST,False);
Assert(B,format('Error: OpenKey(''%s'') failed.',[fqFREEPASCALREGINITEST]));
Assert(RegIni.CurrentPath=fqFREEPASCALREGINITEST,'Expected: CurrenPath='+fqFREEPASCALREGINITEST);
B := TryOpenKey(subRegIni,True);
Assert(B,format('Error: OpenKey(''%s'') failed.',[fqFPCTESTRegIni]));
Assert(RegIni.CurrentPath=fqFPCTESTRegIni,'Expected: CurrenPath='+fqFPCTESTRegIni);
B := TryWriteString(subStrings,idString1,valValue1);
Assert(B,format('Error: WriteString(''%s'',''%s'',''%s'') failed.',[fqFPCTESTStrings,idString1,valValue1]));
writeln('OK');
finally
RegIni.Free;
end;
end;
procedure DeleteFPCTESTEntries;
procedure DeleteStrings;
var
Reg: TRegistry;
B: Boolean;
begin
Reg := TRegistry.Create(KEY_ALL_ACCESS);
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.KeyExists(fqFPCTESTStrings) then
begin
B := Reg.OpenKey(fqFPCTESTStrings, False);
//writeln('OpenKey: ',B);
if B then
begin
B := not Reg.ValueExists(idString1) or Reg.DeleteValue(idString1);
Assert(B, format('Error DeleteValue(''%s'') in %s',[idString1,fqFPCTESTStrings]));
end;
Reg.CloseKey;
end;
if Reg.KeyExists(fqWrongFPCTESTStrings) then
begin
B := Reg.OpenKey(fqWrongFPCTESTStrings, False);
//writeln('OpenKey: ',B);
if B then
begin
B := not Reg.ValueExists(idString1) or Reg.DeleteValue(idString1);
Assert(B, format('Error DeleteValue(''%s'') in %s',[idString1,fqWrongFPCTESTStrings]));
end;
Reg.CloseKey;
end;
finally
Reg.Free;
end;
end;
procedure DeleteEmptyKey(Key: String);
var
Reg: TRegistry;
B: Boolean;
begin
Reg := TRegistry.Create(KEY_ALL_ACCESS);
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.KeyExists(Key) then
begin
B := Reg.DeleteKey(Key);
Assert(B, format('Error DeleteKey(''%s'')',[Key]));
end;
finally
Reg.Free;
end;
end;
begin
DeleteStrings;
DeleteEmptyKey(fqFPCTESTStrings);
DeleteEmptyKey(fqWrongFPCTESTStrings);
DeleteEmptyKey(fqFPCTESTRegIni);
DeleteEmptyKey(fqFREEPASCALREGINITEST);
end;
begin
DeleteFPCTESTEntries;
CreateTestEntries;
CheckCreate;
FindErroneousEntries;
DeleteFPCTESTEntries;
end.