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

* synchronized with trunk

Browse Source 
git-svn-id: branches/unicodekvm@49018 -
This commit is contained in:
nickysn 2021-03-20 04:39:38 +00:00
commit 066bb3c454
21 changed files with 161 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
compiler/pdecsub.pas
View File

@ -2429,7 +2429,7 @@ type
end;
const
{Should contain the number of procedure directives we support.}
num_proc_directives=54;
num_proc_directives=53;
proc_direcdata:array[1..num_proc_directives] of proc_dir_rec=
(
(
@ -2495,15 +2495,6 @@ const
mutexclpocall : [];
mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
mutexclpo : [po_assembler,po_external]
),(
idtok:_DISCARDRESULT;
pd_flags : [pd_interface,pd_implemen,pd_body,pd_procvar];
handler : nil;
pocall : pocall_none;
pooption : [po_discardresult];
mutexclpocall : [];
mutexclpotype : [potype_function,potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
mutexclpo : []
),(
idtok:_DISPID;
pd_flags : [pd_dispinterface];

2
compiler/riscv64/cgcpu.pas
View File

@ -108,6 +108,8 @@ implementation
list.Concat(taicpu.op_reg_reg_const(A_ADDIW,reg2,reg1,0))
else if (tcgsize2unsigned[tosize]=OS_64) and (fromsize=OS_8) then
list.Concat(taicpu.op_reg_reg_const(A_ANDI,reg2,reg1,$FF))
else if (tosize=OS_8) and (fromsize<>OS_8) then
list.Concat(taicpu.op_reg_reg_const(A_ANDI,reg2,reg1,$FF))
else if (tcgsize2size[fromsize] > tcgsize2size[tosize]) or
((tcgsize2size[fromsize] = tcgsize2size[tosize]) and (fromsize <> tosize)) or
{ do we need to mask out the sign when loading from smaller signed to larger unsigned type? }

7
compiler/symconst.pas
View File

@ -435,9 +435,7 @@ type
"varargs" modifier or Mac-Pascal ".." parameter }
po_variadic,
{ implicitly return same type as the class instance to which the message is sent }
po_objc_related_result_type,
{ procedure returns value (like a function), that should be discarded }
po_discardresult
po_objc_related_result_type
);
tprocoptions=set of tprocoption;
@ -1103,8 +1101,7 @@ inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has
'po_is_auto_setter',{po_is_auto_setter}
'po_noinline',{po_noinline}
'C-style array-of-const', {po_variadic}
'objc-related-result-type', {po_objc_related_result_type}
'po_discardresult' { po_discardresult }
'objc-related-result-type' {po_objc_related_result_type}
);
implementation

2
compiler/tokens.pas
View File

@ -305,7 +305,6 @@ type
_OBJCCATEGORY,
_OBJCPROTOCOL,
_WEAKEXTERNAL,
_DISCARDRESULT,
_DISPINTERFACE,
_UNIMPLEMENTED,
_IMPLEMENTATION,
@ -648,7 +647,6 @@ const
(str:'OBJCCATEGORY' ;special:false;keyword:[m_objectivec1];op:NOTOKEN), { Objective-C category }
(str:'OBJCPROTOCOL' ;special:false;keyword:[m_objectivec1];op:NOTOKEN), { Objective-C protocol }
(str:'WEAKEXTERNAL' ;special:false;keyword:[m_none];op:NOTOKEN),
(str:'DISCARDRESULT' ;special:false;keyword:[m_none];op:NOTOKEN),
(str:'DISPINTERFACE' ;special:false;keyword:[m_class];op:NOTOKEN),
(str:'UNIMPLEMENTED' ;special:false;keyword:[m_none];op:NOTOKEN),
(str:'IMPLEMENTATION';special:false;keyword:alllanguagemodes-[m_iso,m_extpas];op:NOTOKEN),

3
compiler/utils/ppuutils/ppudump.pp
View File

@ -2997,8 +2997,7 @@ const
(mask:po_is_auto_setter; str: 'Automatically generated setter'),
(mask:po_noinline; str: 'Never inline'),
(mask:po_variadic; str: 'C VarArgs with array-of-const para'),
(mask:po_objc_related_result_type; str: 'Objective-C related result type'),
(mask:po_discardresult; str: 'Discard result')
(mask:po_objc_related_result_type; str: 'Objective-C related result type')
);
var
proctypeoption : tproctypeoption;

2
compiler/wasm32/hlcgcpu.pas
View File

@ -2055,7 +2055,7 @@ implementation
else
ft:=tcpuprocdef(pd).create_functype;
totalremovesize:=Length(ft.params)-Length(ft.results);
if (Length(ft.results)=0) and (po_discardresult in pd.procoptions) then
if Length(ft.results)=0 then
dec(totalremovesize);
{ remove parameters from internal evaluation stack counter (in case of
e.g. no parameters and a result, it can also increase) }

2
compiler/wasm32/nwasmcal.pas
View File

@ -60,7 +60,7 @@ implementation
procedure twasmcallnode.do_release_unused_return_value;
begin
if is_void(resultdef) and not (po_discardresult in procdefinition.procoptions) then
if is_void(resultdef) then
exit;
current_asmdata.CurrAsmList.concat(taicpu.op_none(a_drop));
thlcgwasm(hlcg).decstack(current_asmdata.CurrAsmList,1);

16
packages/fcl-db/src/sqldb/postgres/pqconnection.pp
View File

@ -845,7 +845,7 @@ const TypeStrings : array[TFieldType] of string =
'time', // ftTime
'timestamp', // ftDateTime
'Unknown', // ftBytes
'Unknown', // ftVarBytes
'bytea', // ftVarBytes
'Unknown', // ftAutoInc
'bytea', // ftBlob
'text', // ftMemo
@ -924,15 +924,15 @@ begin
end
else
begin
if AParams[i].DataType = ftUnknown then
if P.DataType = ftUnknown then
begin
if AParams[i].IsNull then
if P.IsNull then
s:=s+' unknown ,'
else
DatabaseErrorFmt(SUnknownParamFieldType,[AParams[i].Name],self)
DatabaseErrorFmt(SUnknownParamFieldType,[P.Name],self)
end
else
DatabaseErrorFmt(SUnsupportedParameter,[Fieldtypenames[AParams[i].DataType]],self);
DatabaseErrorFmt(SUnsupportedParameter,[Fieldtypenames[P.DataType]],self);
end;
end;
s[length(s)] := ')';
@ -1041,7 +1041,7 @@ begin
end;
ftFmtBCD:
s := BCDToStr(AParams[i].AsFMTBCD, FSQLFormatSettings);
ftBlob, ftGraphic:
ftBlob, ftGraphic, ftVarBytes:
begin
Handled:=true;
bd:= AParams[i].AsBlob;
@ -1064,7 +1064,7 @@ begin
StrMove(PAnsiChar(ar[i]), PAnsiChar(s), L+1);
lengths[i]:=L;
end;
if (AParams[i].DataType in [ftBlob,ftMemo,ftGraphic,ftCurrency]) then
if (AParams[i].DataType in [ftBlob,ftMemo,ftGraphic,ftCurrency,ftVarBytes]) then
Formats[i]:=1
else
Formats[i]:=0;
@ -1338,7 +1338,7 @@ begin
end;
pchar(Buffer + li)^ := #0;
end;
ftBlob, ftMemo :
ftBlob, ftMemo, ftVarBytes :
CreateBlob := True;
ftDate :
begin

4
packages/fcl-passrc/src/pastree.pp
View File

@ -1075,7 +1075,7 @@ type
pmExport, pmOverload, pmMessage, pmReintroduce,
pmInline, pmAssembler, pmPublic,
pmCompilerProc, pmExternal, pmForward, pmDispId,
pmNoReturn, pmFar, pmFinal);
pmNoReturn, pmFar, pmFinal, pmDiscardResult);
TProcedureModifiers = Set of TProcedureModifier;
TProcedureMessageType = (pmtNone,pmtInteger,pmtString);
@ -1779,7 +1779,7 @@ const
'export', 'overload', 'message', 'reintroduce',
'inline','assembler','public',
'compilerproc','external','forward','dispid',
'noreturn','far','final');
'noreturn','far','final','discardresult');
VariableModifierNames : Array[TVariableModifier] of string
= ('cvar', 'external', 'public', 'export', 'class', 'static');

8
packages/fcl-passrc/tests/tcprocfunc.pas
View File

@ -140,6 +140,7 @@ type
Procedure TestFunctionVarArgs;
Procedure TestProcedureCDeclVarargs;
Procedure TestFunctionCDeclVarArgs;
procedure TestFunctionDiscardResult;
Procedure TestProcedureForwardInterface;
Procedure TestFunctionForwardInterface;
Procedure TestProcedureForward;
@ -879,6 +880,13 @@ begin
AssertProc([],[],ccSysCall,0);
end;
procedure TTestProcedureFunction.TestFunctionDiscardResult;
begin
AddDeclaration('function A : Integer; discardresult');
ParseFunction;
AssertFunc([pmDiscardResult],[],ccDefault,0);
end;
procedure TTestProcedureFunction.TestCallingConventionHardFloat;
begin
ParseProcedure('; HardFloat');

3
packages/pastojs/src/pas2jsfiler.pp
View File

@ -513,7 +513,8 @@ const
'DispId',
'NoReturn',
'Far',
'Final'
'Final',
'DiscardResult'
);
PCUProcedureModifiersImplProc = [pmInline,pmAssembler,pmCompilerProc,pmNoReturn];

9
rtl/inc/astrings.inc
View File

@ -872,6 +872,15 @@ end;
{$endif FPC_SYSTEM_HAS_TRUELY_ANSISTR_UNIQUE}
Function fpc_ansistr_Unique_func(Var S : RawByteString): Pointer; external name 'FPC_ANSISTR_UNIQUE';
Procedure UniqueString(var S : RawByteString);{$ifdef FPC_HAS_CPSTRING}rtlproc;{$endif FPC_HAS_CPSTRING}{$ifdef SYSTEMINLINE}inline;{$endif}
begin
fpc_ansistr_Unique_func(S);
end;
{$ifndef FPC_SYSTEM_HAS_ANSISTR_UNIQUE}
{$define FPC_SYSTEM_HAS_ANSISTR_UNIQUE}
// MV: inline the basic checks for case that S is already unique.

2
rtl/inc/systemh.inc
View File

@ -1319,7 +1319,7 @@ function Pos(const substr : shortstring;c:char; Offset: Sizeint = 1): SizeInt;
****************************************************************************}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Procedure UniqueString(var S : RawByteString);{$ifdef FPC_HAS_CPSTRING}rtlproc;{$endif FPC_HAS_CPSTRING}external name 'FPC_ANSISTR_UNIQUE';{$ifndef VER3_2}discardresult;{$endif VER3_2}
Procedure UniqueString(var S : RawByteString);{$ifdef FPC_HAS_CPSTRING}rtlproc;{$endif FPC_HAS_CPSTRING}{$ifdef SYSTEMINLINE}inline;{$endif}
Function Pos (const Substr : RawByteString; const Source : RawByteString; Offset: Sizeint = 1) : SizeInt;
Function Pos (c : AnsiChar; const s : RawByteString; Offset: Sizeint = 1) : SizeInt;
{$ifdef VER3_0}

2
rtl/inc/ustringh.inc
View File

@ -15,7 +15,7 @@
**********************************************************************}
Procedure UniqueString (Var S : UnicodeString);external name 'FPC_UNICODESTR_UNIQUE';{$ifndef VER3_2}discardresult;{$endif VER3_2}
Procedure UniqueString (Var S : UnicodeString);{$ifdef SYSTEMINLINE}inline;{$endif}
Function Pos (Const Substr : UnicodeString; Const Source : UnicodeString; Offset: Sizeint = 1) : SizeInt;
Function Pos (c : Char; Const s : UnicodeString; Offset: Sizeint = 1) : SizeInt;
Function Pos (c : UnicodeChar; Const s : UnicodeString; Offset: Sizeint = 1) : SizeInt;

9
rtl/inc/ustrings.inc
View File

@ -1104,6 +1104,15 @@ procedure WideCharToStrVar(S : PWideChar;out Dest : AnsiString);
end;
Function fpc_unicodestr_Unique_func(Var S : UnicodeString): Pointer; external name 'FPC_UNICODESTR_UNIQUE';
Procedure UniqueString (Var S : UnicodeString);{$ifdef SYSTEMINLINE}inline;{$endif}
begin
fpc_unicodestr_Unique_func(S);
end;
{$ifndef FPC_HAS_UNICODESTR_UNIQUE}
{$define FPC_HAS_UNICODESTR_UNIQUE}
Function fpc_unicodestr_Unique(Var S : Pointer): Pointer; [Public,Alias : 'FPC_UNICODESTR_UNIQUE']; compilerproc;

2
rtl/inc/wstringh.inc
View File

@ -15,7 +15,7 @@
**********************************************************************}
Procedure UniqueString (Var S : WideString);external name 'FPC_WIDESTR_UNIQUE';{$ifndef VER3_2}discardresult;{$endif VER3_2}
Procedure UniqueString (Var S : WideString);{$ifdef SYSTEMINLINE}inline;{$endif}
Function Pos (Const Substr : WideString; Const Source : WideString; Offset : SizeInt = 1) : SizeInt;
Function Pos (c : Char; Const s : WideString; Offset : SizeInt = 1) : SizeInt;
Function Pos (c : WideChar; Const s : WideString; Offset : SizeInt = 1) : SizeInt;

9
rtl/inc/wstrings.inc
View File

@ -546,6 +546,15 @@ end;
Public functions, In interface.
*****************************************************************************}
Function fpc_widestr_Unique_func(Var S : WideString): Pointer; external name 'FPC_WIDESTR_UNIQUE';
Procedure UniqueString (Var S : WideString);{$ifdef SYSTEMINLINE}inline;{$endif}
begin
fpc_widestr_Unique_func(S);
end;
Function fpc_widestr_Unique(Var S : Pointer): Pointer; [Public,Alias : 'FPC_WIDESTR_UNIQUE']; compilerproc;
begin
pointer(result) := pointer(s);

61
rtl/unix/timezone.inc
View File

@ -29,7 +29,7 @@ type
pleap=^tleap;
tleap=record
transition : int64;
change : int64;
change : longint;
end;
var
@ -64,8 +64,22 @@ var
else
Exit(0);
end;
var
timerLoUTC, timerHiUTC: int64;
begin
if (num_transitions=0) or (timer<transitions[0]) then
if (num_transitions>0) and not timerIsUTC then
begin
timerLoUTC:=timer-types[type_idxs[0]].offset;
timerHiUTC:=timer-types[type_idxs[num_transitions-1]].offset;
end
else
begin
timerLoUTC:=timer;
timerHiUTC:=timer;
end;
if (num_transitions=0) or (timerLoUTC<transitions[0]) then
{ timer is before the first transition }
begin
i:=0;
while (i<num_types) and (types[i].isdst) do
@ -77,6 +91,15 @@ begin
trans_end:=high(trans_end);
end
else
if (num_transitions>0) and (timerHiUTC>=transitions[num_transitions-1]) then
{ timer is after the last transition }
begin
i:=type_idxs[num_transitions-1];
trans_start:=transitions[num_transitions-1];
trans_end:=high(trans_end);
end
else
{ timer inbetween }
begin
// Use binary search.
L := 1;
@ -254,19 +277,34 @@ const
var
buf : array[0..bufsize-1] of byte;
bufptr : pbyte;
bufbytes : tsSize;
bufoverflow : boolean;
f : longint;
tzhead : ttzhead;
procedure readfilebuf;
function readfilebuf : TsSize;
begin
bufptr := @buf[0];
fpread(f, buf, bufsize);
bufbytes:=fpread(f, buf, bufsize);
readfilebuf:=bufbytes;
end;
Procedure checkbufptr(asize : integer);
var
a : tssize;
begin
a:=bufptr-@buf+asize;
if (a>bufbytes) then
bufoverflow:=true;
end;
function readbufbyte: byte;
begin
if bufptr > @buf[bufsize-1] then
readfilebuf;
checkbufptr(1);
readbufbyte := bufptr^;
inc(bufptr);
end;
@ -282,6 +320,7 @@ var
numbytes := count;
if numbytes > 0 then
begin
checkbufptr(numbytes);
if assigned(dest) then
move(bufptr^, dest^, numbytes);
inc(bufptr, numbytes);
@ -380,13 +419,12 @@ var
end;
readbuf(zone_names,tzhead.tzh_charcnt);
if version=2 then
begin // read 64bit values
for i:=0 to num_leaps-1 do
begin
readbuf(@leaps[i].transition,sizeof(int64));
readbuf(@leaps[i].change,sizeof(int64));
readbuf(@leaps[i].change,sizeof(longint));
leaps[i].transition:=decode(leaps[i].transition);
leaps[i].change:=decode(leaps[i].change);
end;
@ -410,6 +448,13 @@ var
readdata:=true;
end;
procedure ClearCurrentTZinfo;
var
i:integer;
begin
for i:=low(CurrentTZinfo) to high(CurrentTZinfo) do
CurrentTZinfo[i] := Default(TTZInfo);
end;
begin
if fn='' then
fn:='localtime';
@ -418,10 +463,12 @@ begin
f:=fpopen(fn,Open_RdOnly);
if f<0 then
exit(False);
bufoverflow:=false;
bufptr := @buf[bufsize-1]+1;
tzhead:=default(ttzhead);
LockTZInfo;
ReadTimezoneFile:=(readheader() and readdata());
ReadTimezoneFile:=(readheader() and readdata()) and not BufOverflow;
ClearCurrentTZinfo;
UnlockTZInfo;
fpclose(f);
end;

49
tests/test/units/unix/ttimezone1.pp
View File

@ -31,9 +31,10 @@ begin
end;
begin
if not ReadTimezoneFile('Europe/Vienna') then // check against Europe/Vienna file
// check against Europe/Vienna file
if not ReadTimezoneFile('Europe/Vienna') then
begin
writeln('timezone file not found');
writeln('Europe/Vienna timezone file not found');
halt(10);
end;
@ -52,5 +53,49 @@ begin
if GetOffset(2019, 10, 27, 0, 59, 0, True)<>2 then Halt(17);
if GetOffset(2019, 10, 27, 1, 0, 0, True)<>1 then Halt(18);
// check against Europe/Moscow file
if not ReadTimezoneFile('Europe/Moscow') then
begin
writeln('Europe/Moscow timezone file not found');
halt(20);
end;
{
https://en.wikipedia.org/wiki/Time_in_Russia
Daylight saving time was re-introduced in the USSR in 1981, beginning on 1 April and ending on 1 October each year,
until mid-1984, when the USSR began following European daylight saving time rules, moving clocks forward one hour
at 02:00 local standard time on the last Sunday in March, and back one hour at 03:00 local daylight time on the last
Sunday in September until 1995, after which the change back occurred on the last Sunday in October.
On 27 March 2011, clocks were advanced as usual, but they did not go back on 30 October 2011, effectively making
Moscow Time UTC+04:00 permanently. On 26 October 2014, following another change in the law, the clocks in most
of the country were moved back one hour, but summer Daylight Time was not reintroduced; Moscow Time returned
to UTC+03:00 permanently.
}
if GetOffset(1994, 03, 26, 0, 0, 0, True)<>3 then Halt(21);
if GetOffset(1994, 03, 27, 0, 0, 0, True)<>4 then Halt(22);
if GetOffset(1994, 09, 24, 0, 0, 0, True)<>4 then Halt(23);
if GetOffset(1994, 09, 25, 0, 0, 0, True)<>3 then Halt(24);
if GetOffset(1996, 03, 30, 0, 0, 0, True)<>3 then Halt(25);
if GetOffset(1996, 03, 31, 0, 0, 0, True)<>4 then Halt(26);
if GetOffset(1996, 10, 26, 0, 0, 0, True)<>4 then Halt(27);
if GetOffset(1996, 10, 27, 0, 0, 0, True)<>3 then Halt(28);
if GetOffset(2011, 03, 26, 0, 0, 0, True)<>3 then Halt(29);
if GetOffset(2011, 03, 27, 0, 0, 0, True)<>4 then Halt(30);
if GetOffset(2011, 09, 01, 0, 0, 0, True)<>4 then Halt(31);
if GetOffset(2011, 11, 01, 0, 0, 0, True)<>4 then Halt(32);
if GetOffset(2012, 06, 01, 0, 0, 0, True)<>4 then Halt(33);
if GetOffset(2014, 10, 25, 0, 0, 0, True)<>4 then Halt(34);
if GetOffset(2014, 10, 26, 0, 0, 0, True)<>3 then Halt(35);
if GetOffset(2021, 03, 31, 0, 0, 0, True)<>3 then Halt(36);
writeln('ok');
end.

1
utils/fpdoc/dwriter.pp
View File

@ -854,7 +854,6 @@ begin
Result:=Not Assigned(FOutputPageNames);
if Not Result then
Result:=FOutputPageNames.IndexOf(aFileName)<>-1;
Writeln(afilename ,': ',result);
end;
class procedure TMultiFileDocWriter.Usage(List: TStrings);

3
utils/pas2js/httpcompiler.pp
View File

@ -558,12 +558,13 @@ begin
S:=Checkoptions('shqd:ni:p:wP::cm:',['help','quiet','noindexpage','directory:','port:','indexpage:','watch','project::','config:','simpleserver','mimetypes:']);
if (S<>'') or HasOption('h','help') then
usage(S);
FServeOnly:=HasOption('s','serve-only');
FServeOnly:=HasOption('s','simpleserver');
Quiet:=HasOption('q','quiet');
Port:=StrToIntDef(GetOptionValue('p','port'),3000);
D:=GetOptionValue('d','directory');
if D='' then
D:=GetCurrentDir;
D:=ExpandFileName(D);
if HasOption('m','mimetypes') then
MimeTypesFile:=GetOptionValue('m','mimetypes');
if MimeTypesFile='' then