Merged revisions 9893,10073,10082,10094-10098,10101,10121,10129-10130,10135 via svnmerge from

http://svn.freepascal.org/svn/fpc/trunk

........
  r9893 | jonas | 2008-01-24 11:33:14 +0100 (Thu, 24 Jan 2008) | 2 lines
  
    * fixed webtbs/tw10519.pp for CPUs which don't support extended
........
  r10073 | jonas | 2008-01-27 23:06:07 +0100 (Sun, 27 Jan 2008) | 4 lines
  
    * fix for (w)chararray to ansi/widestring conversions after
      ansi/widestring function handling change in r9718 (patch by
      Sergei Gorelkin)
........
  r10094 | michael | 2008-01-29 13:31:24 +0100 (Tue, 29 Jan 2008) | 1 line
  
  * Implemented Loading, as per Graeme Geldenhuys request
........
  r10095 | michael | 2008-01-29 14:08:54 +0100 (Tue, 29 Jan 2008) | 1 line
  
  * Patch from Giuliano Colla to fix tbits.size
........
  r10096 | marco | 2008-01-29 20:35:01 +0100 (Tue, 29 Jan 2008) | 1 line
  
   * pbyte killed, it is in systems nowadays 
........
  r10097 | marco | 2008-01-29 20:37:41 +0100 (Tue, 29 Jan 2008) | 1 line
  
   * remove some redundant pbyte definitions.
........
  r10098 | marco | 2008-01-29 21:06:38 +0100 (Tue, 29 Jan 2008) | 1 line
  
   * Delphi compat overload reenabled.
........
  r10101 | marco | 2008-01-29 22:02:13 +0100 (Tue, 29 Jan 2008) | 1 line
  
   * interlockedincrement  aliased for delphi compat
........
  r10121 | marco | 2008-01-30 23:50:51 +0100 (Wed, 30 Jan 2008) | 2 lines
  
   * plresult for IContextMenu<x>
........
  r10135 | yury | 2008-02-01 18:42:41 +0100 (Fri, 01 Feb 2008) | 1 line
  
  * Fixed 3 warnings and 1 note.
........

git-svn-id: branches/fixes_2_2@10161 -

.gitattributes

@@ -7349,6 +7349,7 @@ tests/test/tstring5.pp svneol=native#text/plain
 tests/test/tstring6.pp svneol=native#text/plain
 tests/test/tstring7.pp svneol=native#text/plain
 tests/test/tstring8.pp svneol=native#text/plain
+tests/test/tstring9.pp svneol=native#text/plain
 tests/test/tstrreal1.pp svneol=native#text/plain
 tests/test/tstrreal2.pp svneol=native#text/plain
 tests/test/tstrreal3.pp -text

rtl/inc/astrings.inc

@@ -406,11 +406,12 @@ Var
   L : SizeInt;
 begin
   if (not assigned(p)) or (p[0]=#0) Then
-    { result is automatically set to '' }
-    exit;
-  l:=IndexChar(p^,-1,#0);
+    L := 0
+  else
+    l:=IndexChar(p^,-1,#0);
   SetLength(fpc_PChar_To_AnsiStr,L);
-  Move (P[0],Pointer(fpc_PChar_To_AnsiStr)^,L)
+  if L > 0 then
+    Move (P[0],Pointer(fpc_PChar_To_AnsiStr)^,L)
 end;
 
 
@@ -422,16 +423,19 @@ begin
   if (zerobased) then
     begin
       if (arr[0]=#0) Then
-        { result is automatically set to '' }
-        exit;
-      i:=IndexChar(arr,high(arr)+1,#0);
-      if i = -1 then
-        i := high(arr)+1;
+        i := 0
+      else
+      begin  
+        i:=IndexChar(arr,high(arr)+1,#0);
+        if i = -1 then
+          i := high(arr)+1;
+      end;    
     end
   else
     i := high(arr)+1;
   SetLength(fpc_CharArray_To_AnsiStr,i);
-  Move (arr[0],Pointer(fpc_CharArray_To_AnsiStr)^,i);
+  if i > 0 then
+    Move (arr[0],Pointer(fpc_CharArray_To_AnsiStr)^,i);
 end;
 
 {$ifndef FPC_STRTOCHARARRAYPROC}

rtl/inc/wustrings.inc

@@ -716,8 +716,10 @@ Var
   L : SizeInt;
 begin
   if (not assigned(p)) or (p[0]=#0) Then
-    { result is automatically set to '' }
+  begin
+    fpc_pchar_to_widestr := '';
     exit;
+  end;  
   l:=IndexChar(p^,-1,#0);
   widestringmanager.Ansi2WideMoveProc(P,fpc_PChar_To_WideStr,l);
 end;
@@ -730,8 +732,10 @@ begin
   if (zerobased) then
     begin
       if (arr[0]=#0) Then
-        { result is automatically set to '' }
+      begin
+        fpc_chararray_to_widestr := '';
         exit;
+      end;  
       i:=IndexChar(arr,high(arr)+1,#0);
       if i = -1 then
         i := high(arr)+1;

rtl/objpas/classes/bits.inc

@@ -1,6 +1,6 @@
 {
     This file is part of the Free Component Library (FCL)
-    Copyright (c) 1999-2000 by the Free Pascal development team
+    Copyright (c) 1999-2008 by the Free Pascal development team
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -26,29 +26,62 @@ begin
   Raise EBitsError.CreateFmt(Msg,args) at get_caller_addr(get_frame);
 end;
 
+{Min function for Longint}
+Function liMin(X, Y: Longint): Longint;
+  begin
+    Result := X;
+    if X > Y then Result := Y;
+  end;
+
 procedure TBits.CheckBitIndex (Bit : longint;CurrentSize : Boolean);
 
 begin
- if (bit<0) or (CurrentSize and (Bit>Size)) then
+ if (bit<0) or (CurrentSize and (Bit >= FBSize)) then
    BitsErrorFmt(SErrInvalidBitIndex,[bit]);
  if (bit>=MaxBitFlags) then
    BitsErrorFmt(SErrIndexTooLarge,[bit])
 
 end;
 
+procedure TBits.Resize(Nbit: longint);
+var
+   newSize : longint;
+   loop : longint;
+begin
+   CheckBitindex(nbit,false);
+
+   newSize :=  (nbit shr BITSHIFT) + 1;
+
+   if newSize <> FSize then
+   begin
+      ReAllocMem(FBits, newSize * SizeOf(longint));
+      if FBits <> nil then
+        begin
+         if newSize > FSize then
+            for loop := FSize to newSize - 1 do
+               FBits^[loop] := 0;
+         FSize := newSize;
+         FBSize := nbit + 1;
+       end
+      else
+        BitsError(SErrOutOfMemory);
+   end;
+end;
+
 { ************* functions to match TBits class ************* }
 
 function TBits.getSize : longint;
 begin
-   result := (FSize shl BITSHIFT) - 1;
+   result := FBSize;
 end;
 
 procedure TBits.setSize(value : longint);
 begin
    if value=0 then
-    grow(0) // truncate
+    resize(0) // truncate
    else
-    grow(value - 1);
+     Resize(value - 1);
+   FBSize:= value;
 end;
 
 procedure TBits.SetBit(bit : longint; value : Boolean);
@@ -64,6 +97,7 @@ var
    loop : longint;
    loop2 : longint;
    startIndex : longint;
+   stopIndex : Longint;
 begin
    result := -1; {should only occur if the whole array is set}
    for loop := 0 to FSize - 1 do
@@ -71,7 +105,8 @@ begin
       if FBits^[loop] <> $FFFFFFFF then
       begin
          startIndex := loop * 32;
-         for loop2 := startIndex to startIndex + 31 do
+         stopIndex := liMin ( FBSize -1,startIndex + 31) ;
+         for loop2 := startIndex to stopIndex do
          begin
             if get(loop2) = False then
             begin
@@ -79,6 +114,10 @@ begin
                break; { use this as the index to return }
             end;
          end;
+         if result = -1 then begin
+           result := FBSize;
+           inc(FBSize);
+           end;
          break;  {stop looking for empty bit in records }
       end;
    end;
@@ -93,10 +132,11 @@ end;
 constructor TBits.Create(theSize : longint = 0 );
 begin
    FSize := 0;
+   FBSize := 0;
    FBits := nil;
    findIndex := -1;
    findState := True;  { no reason just setting it to something }
-   grow(theSize);
+   if TheSize > 0 then grow(theSize-1);
 end;
 
 destructor TBits.Destroy;
@@ -111,25 +151,9 @@ end;
 procedure TBits.grow(nbit : longint);
 var
    newSize : longint;
-   loop : longint;
 begin
-   CheckBitindex(nbit,false);
-
    newSize :=  (nbit shr BITSHIFT) + 1;
-
-   if newSize > FSize then
-   begin
-      ReAllocMem(FBits, newSize * SizeOf(longint));
-      if FBits <> nil then
-        begin
-         if newSize > FSize then
-            for loop := FSize to newSize - 1 do
-               FBits^[loop] := 0;
-         FSize := newSize;
-       end
-      else
-        BitsError(SErrOutOfMemory);
-   end;
+   if newSize > FSize then Resize(nbit);
 end;
 
 function TBits.getFSize : longint;
@@ -144,6 +168,7 @@ begin
    n := bit shr BITSHIFT;
    grow(bit);
    FBits^[n] := FBits^[n] or (longint(1) shl (bit and MASK));
+   if bit >= FBSize then FBSize := bit;
 end;
 
 procedure TBits.clear(bit : longint);
@@ -154,6 +179,7 @@ begin
    n := bit shr BITSHIFT;
    grow(bit);
    FBits^[n] := FBits^[n] and not(longint(1) shl (bit and MASK));
+   if bit >= FBSize then FBSize := bit + 1;
 end;
 
 procedure TBits.clearall;
@@ -162,6 +188,8 @@ var
 begin
    for loop := 0 to FSize - 1 do
       FBits^[loop] := 0;
+   {Should FBSize be cleared too? - I think so}
+   FBSize := 0;
 end;
 
 function TBits.get(bit : longint) : Boolean;
@@ -275,6 +303,7 @@ end;
 
 procedure TBits.SetIndex(index : longint);
 begin
+   CheckBitIndex(index,true);
    findIndex := index;
 end;
 
@@ -288,6 +317,7 @@ var
    loop : longint;
    loop2 : longint;
    startIndex : longint;
+   stopIndex : Longint;
    compareVal : cardinal;
 begin
    result := -1; {should only occur if none are set}
@@ -304,7 +334,8 @@ begin
       if FBits^[loop] <> compareVal then
       begin
          startIndex := loop * 32;
-         for loop2 := startIndex to startIndex + 31 do
+         stopIndex:= liMin(StartIndex+31,FBSize -1);
+         for loop2 := startIndex to stopIndex do
          begin
             if get(loop2) = state then
             begin

rtl/objpas/classes/compon.inc

@@ -233,6 +233,12 @@ begin
   Exclude(FComponentState,csLoading);
 end;
 
+Procedure TComponent.Loading;
+
+begin
+  Include(FComponentState,csLoading);
+end;
+
 
 Procedure TComponent.Notification(AComponent: TComponent;
   Operation: TOperation);

rtl/objpas/classes/streams.inc

@@ -346,8 +346,7 @@ end;
     end;
 
   Function TStream.ReadAnsiString : String;
-  Type
-    PByte = ^Byte;
+
   Var
     TheSize : Longint;
     P : PByte ;

rtl/objpas/dateutil.inc

@@ -2006,22 +2006,23 @@ begin
   TryJulianDateToDateTime := ADateTime <> NaN;
 end;
 
-
 Function DateTimeToModifiedJulianDate(const AValue: TDateTime): Double;
 begin
+  Result:=0;
   NotYetImplemented('DateTimeToModifiedJulianDate');
 end;
 
 
 Function ModifiedJulianDateToDateTime(const AValue: Double): TDateTime;
 begin
+  Result:=0;
   NotYetImplemented('ModifiedJulianDateToDateTime');
 end;
 
 
 Function TryModifiedJulianDateToDateTime(const AValue: Double; var ADateTime: TDateTime): Boolean;
-
 begin
+  Result:=False;
   NotYetImplemented('TryModifiedJulianDateToDateTime');
 end;
 

rtl/objpas/sysutils/syspch.inc

@@ -23,7 +23,6 @@
 {  PChar functions  }
 
 type
-   pbyte = ^byte;
    CharArray = array[0..0] of char;
 
 { Processor dependent part, shared withs strings unit }

rtl/objpas/sysutils/sysstr.inc

@@ -1992,7 +1992,18 @@ Var
         Placehold[1]:=1;
       Decimals := Placehold[3] + Placehold[4];
       Width:=Placehold[1]+Placehold[2]+Decimals;
+      { depending on the maximally supported precision, the exponent field }
+      { is longer/shorter                                                  }
+{$ifdef FPC_HAS_TYPE_EXTENDED}
       Str(Value:Width+8,Digits);
+{$else FPC_HAS_TYPE_EXTENDED}
+{$ifdef FPC_HAS_TYPE_DOUBLE}
+      Str(Value:Width+7,Digits);
+{$else FPC_HAS_TYPE_DOUBLE}
+      Str(Value:Width+6,Digits);
+{$endif FPC_HAS_TYPE_DOUBLE}
+{$endif FPC_HAS_TYPE_EXTENDED}
+
       { Find and cut out exponent. Always the
         last 6 characters in the string.
         -> 0000E+0000                         

rtl/win/wininc/base.inc

@@ -141,7 +141,7 @@
 
      LP     = ^word;
      LPBOOL = ^WINBOOL;
-     LPBYTE = ^BYTE;
+     LPBYTE = pbyte;
      LPCCH  = PCHAR;
      LPCH   = PCHAR;
 
@@ -178,6 +178,7 @@
 {$endif}
 
      LRESULT = LONG_PTR;
+     PLRESULT= ^LRESULT;
 
      LPVOID  = pointer;
      LPCVOID = pointer;
@@ -190,7 +191,7 @@
      PWINBOOL = ^WINBOOL;
      PBOOLEAN = ^BYTE;
 
-     PBYTE = ^BYTE;
+     PBYTE = System.PByte;
 
      PCCH = PCHAR;
      PCH  = PCHAR;
@@ -200,7 +201,7 @@
      PCWCH  = Pwidechar;
      PCWSTR = Pwidechar;
 
-     PDWORD = ^DWORD;
+     PDWORD = System.PDWORD;
 
      PHANDLE = ^HANDLE;
      PHKEY = ^HKEY;
@@ -228,7 +229,7 @@
      PWCH   = Pwidechar;
      PWCHAR = Pwidechar;
 
-     PWORD   = ^word;
+     PWORD   = System.PWord;
      PUINT   = ^cardinal;
      PULONG  = ^cardinal;
      PUSHORT = ^word;

rtl/win/wininc/redef.inc

@@ -626,7 +626,7 @@ function GetThreadSelectorEntry(hThread: THandle; dwSelector: DWORD; var lpSelec
 function GetThreadTimes(hThread: THandle; var lpCreationTime, lpExitTime, lpKernelTime, lpUserTime: TFileTime): BOOL; external 'kernel32' name 'GetThreadTimes';
 function GetTimeZoneInformation(var lpTimeZoneInformation: TTimeZoneInformation): DWORD; external 'kernel32' name 'GetTimeZoneInformation';
 //function GetTitleBarInfo(hwnd: HWND; var pti: TTitleBarInfo): BOOL;external 'user32' name 'GetTitleBarInfo';
-//function GetTokenInformation(TokenHandle: THandle; TokenInformationClass: TTokenInformationClass; TokenInformation: Pointer; TokenInformationLength: DWORD; var ReturnLength: DWORD): BOOL; external 'advapi32' name 'GetTokenInformation';
+function GetTokenInformation(TokenHandle: THandle; TokenInformationClass: TTokenInformationClass; TokenInformation: Pointer; TokenInformationLength: DWORD; var ReturnLength: DWORD): BOOL; external 'advapi32' name 'GetTokenInformation';
 function GetUpdateRect(hWnd: HWND; var lpRect: TRect; bErase: BOOL): BOOL; external 'user32' name 'GetUpdateRect';
 function GetUserName(lpBuffer: PChar; var nSize: DWORD): BOOL;external 'advapi32' name 'GetUserNameA';
 function GetUserNameA(lpBuffer: LPCSTR; var nSize: DWORD): BOOL; external 'advapi32' name 'GetUserNameA';
@@ -1004,9 +1004,18 @@ function GetWindowThreadProcessId(hWnd:HWND;var lpdwProcessId:DWORD):DWORD; exte
 function HwndMSWheel(var puiMsh_MsgMouseWheel, puiMsh_Msg3DSupport,puiMsh_MsgScrollLines: UINT;
   var pf3DSupport: BOOL; var piScrollLines: Integer): HWND;
 function CreateWaitableTimer(lpTimerAttributes :LPSECURITY_ATTRIBUTES; bManualReset:BOOl;lpTimerName:LPCTSTR):THandle;external 'kernel32' name 'CreateWaitableTimerA'; 
-function OpenWaitableTimer(dwDesiredAccess:DWORD;bInheritHandle:BOOL;lpTimerName:LPCTSTR):THandle;external 'kernel32' name 'OpenWaitableTimerA'; 
+function OpenWaitableTimer(dwDesiredAccess:DWORD;bInheritHandle:BOOL;lpTimerName:LPCTSTR):THandle;external 'kernel32' name 'OpenWaitableTimerA';
 function PropertySheetA(p:TPROPSHEETHEADER):longint; external 'comctl32' name 'PropertySheetA';
 
+// windows because of Delphi compat.
+
+function InterLockedIncrement (var Target: longint) : longint; external name 'FPC_INTERLOCKEDINCREMENT';
+function InterLockedDecrement (var Target: longint) : longint; external name 'FPC_INTERLOCKEDDECREMENT';
+function InterLockedExchange (var Target: longint;Source : longint) : longint; external name 'FPC_INTERLOCKEDEXCHANGE';
+function InterLockedExchangeAdd (var Target: longint;Source : longint) : longint; external name 'FPC_INTERLOCKEDEXCHANGEADD';
+function InterlockedCompareExchange(var Target: longint; NewValue: longint; Comperand: longint): longint; external name 'FPC_INTERLOCKEDCOMPAREEXCHANGE';
+
+
 {$endif read_interface}
 
 

rtl/wince/dos.pp

@@ -406,7 +406,7 @@ end;
 
 Function FSearch(path: pathstr; dirlist: string): pathstr;
 var
-  i,p1   : longint;
+  p1     : longint;
   s      : searchrec;
   newdir : pathstr;
 begin

tests/test/tstring9.pp

@@ -0,0 +1,56 @@
+program tst2;
+{$ifdef fpc}{$mode objfpc}{$h+}{$endif}
+
+var
+ a: array[0..0] of char = (#0);
+
+function test_pchar: boolean;
+var
+ s: string;
+ p: pchar;
+begin
+ p := '';
+ s := '1234567890';
+ s := p;
+ test_pchar := (s = '');
+ if not test_pchar then writeln('test_pchar failed');
+end;
+
+function test_chararray: boolean;
+var
+ s: string;
+begin
+ s := '1234567890';
+ s := a;
+ test_chararray := (s = '');
+ if not test_chararray then writeln('test_chararray failed');  
+end;
+
+function test_pchar_to_widestr: boolean;
+var
+ s: widestring;
+ p: PChar;
+begin
+ p := '';
+ s := '1234567890';
+ s := p;                         { win32: function result assign not optimized! }
+ test_pchar_to_widestr := (s = '');
+ if not test_pchar_to_widestr then writeln('test_pchar_to_widestr failed');  
+end;
+
+function test_chararray_to_widestr: boolean;
+var
+ s: widestring;
+begin
+ s := '1234567890';
+ s := a;
+ test_chararray_to_widestr := (s = '');
+ if not test_chararray_to_widestr then writeln('test_chararray_to_widestr failed');  
+end;
+
+begin
+ if not test_pchar then Halt(1);
+ if not test_chararray then Halt(2);
+ if not test_pchar_to_widestr then Halt(3);
+ if not test_chararray_to_widestr then Halt(4);
+end.