* synchronized with trunk

git-svn-id: branches/unicodekvm@49018 -

compiler/pdecsub.pas

@@ -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];

compiler/riscv64/cgcpu.pas

@@ -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? }

compiler/symconst.pas

@@ -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

compiler/tokens.pas

@@ -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),

compiler/utils/ppuutils/ppudump.pp

@@ -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;

compiler/wasm32/hlcgcpu.pas

@@ -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) }

compiler/wasm32/nwasmcal.pas

@@ -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);

packages/fcl-db/src/sqldb/postgres/pqconnection.pp

@@ -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

packages/fcl-passrc/src/pastree.pp

@@ -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');

packages/fcl-passrc/tests/tcprocfunc.pas

@@ -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');

packages/pastojs/src/pas2jsfiler.pp

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

rtl/inc/astrings.inc

@@ -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.

rtl/inc/systemh.inc

@@ -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}

rtl/inc/ustringh.inc

@@ -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;

rtl/inc/ustrings.inc

@@ -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;

rtl/inc/wstringh.inc

@@ -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;

rtl/inc/wstrings.inc

@@ -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);

rtl/unix/timezone.inc

@@ -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;

tests/test/units/unix/ttimezone1.pp

@@ -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.

utils/fpdoc/dwriter.pp

@@ -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);

utils/pas2js/httpcompiler.pp

@@ -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