Merged revisions 7911,7914,7917 via svnmerge from

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

........
  r7911 | yury | 2007-07-01 21:57:49 +0300 (Вс, 01 июл 2007) | 1 line
  
  * Clean fix for bug #9170. Thanks Peter.
........
  r7914 | yury | 2007-07-01 23:29:01 +0300 (Вс, 01 июл 2007) | 1 line
  
  * Small addition to r7911.
........
  r7917 | yury | 2007-07-02 00:57:39 +0300 (Пн, 02 июл 2007) | 3 lines
  
  * Reallocate source winlike widestring on assign. It fixes bug #9190.
  * Error handling on allocating winlike widestring.
  + Test.
........

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

.gitattributes

@@ -8150,6 +8150,7 @@ tests/webtbs/tw9107.pp svneol=native#text/plain
 tests/webtbs/tw9174.pp svneol=native#text/plain
 tests/webtbs/tw9179.pp svneol=native#text/plain
 tests/webtbs/tw9187.pp svneol=native#text/plain
+tests/webtbs/tw9190.pp svneol=native#text/plain
 tests/webtbs/ub1873.pp svneol=native#text/plain
 tests/webtbs/ub1883.pp svneol=native#text/plain
 tests/webtbs/uw0555.pp svneol=native#text/plain

rtl/inc/wstrings.inc

@@ -152,7 +152,11 @@ Var
 begin
 {$ifdef MSWINDOWS}
   if winwidestringalloc then
-    P:=SysAllocStringLen(nil,Len)
+    begin
+      P:=SysAllocStringLen(nil,Len);
+      if P=nil then
+        WideStringError;
+    end
   else
 {$endif MSWINDOWS}
     begin
@@ -195,6 +199,19 @@ begin
   S:=Nil;
 end;
 
+{$ifdef FPC_WINLIKEWIDESTRING}
+var
+  __data_start: byte; external name '__data_start__';
+  __data_end: byte; external name '__data_end__';
+  
+function IsWideStringConstant(S: pointer): boolean;{$ifdef SYSTEMINLINE}inline;{$endif}
+{
+  Returns True if widestring is constant (located in .data section);
+}
+begin
+  Result:=(S>=@__data_start) and (S<@__data_end);
+end;
+{$endif FPC_WINLIKEWIDESTRING}
 
 Procedure fpc_WideStr_Decr_Ref (Var S : Pointer);[Public,Alias:'FPC_WIDESTR_DECR_REF']; compilerproc;
 {
@@ -222,13 +239,7 @@ Begin
     { Ref count dropped to zero ...
       ... remove }
 {$else}
-  { Here we check if widestring is constant (located in .data section).
-    initialstklen variable is compiler generated and always located at the beginning of .data section.
-    ExitCode is zero initialized variable and located somewhere in .bss section which is followed
-    by .data section in memory.
-    If widestring points to the address space between initialstklen and ExitCode then it is constant
-    and there is no need to dispose it. }
-  if (S<@initialstklen) or (S>@ExitCode) then
+  if not IsWideStringConstant(S) then
 {$endif FPC_WINLIKEWIDESTRING}
     DisposeWideString(S);
 end;
@@ -382,15 +393,33 @@ Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[Public,Alias:'FPC_
 begin
 {$ifdef FPC_WINLIKEWIDESTRING}
   if S1=S2 then exit;
-  { Decrease the reference count on the old S1 }
-  fpc_widestr_decr_ref (S1);
   if S2<>nil then
     begin
-      S1:=NewWidestring(length(WideString(S2)));
-      move(s2^,s1^,(length(WideString(s1))+1)*sizeof(widechar));
+      if IsWideStringConstant(S1) then
+        begin
+          S1:=NewWidestring(length(WideString(S2)));
+          move(s2^,s1^,(length(WideString(s1))+1)*sizeof(widechar));
+        end
+      else
+{$ifdef MSWINDOWS}
+        if winwidestringalloc then
+          begin
+            if SysReAllocStringLen(S1, S2, Length(WideString(S2))) = 0 then
+              WideStringError;
+          end
+        else
+{$endif MSWINDOWS}
+          begin
+            SetLength(WideString(S1),length(WideString(S2)));
+            move(s2^,s1^,(length(WideString(s1))+1)*sizeof(widechar));
+          end;
     end
   else
-    S1:=nil;
+    begin
+      { Free S1 }
+      fpc_widestr_decr_ref (S1);
+      S1:=nil;
+    end;
 {$else FPC_WINLIKEWIDESTRING}
   If S2<>nil then
     If PWideRec(S2-WideFirstOff)^.Ref>0 then
@@ -921,12 +950,16 @@ begin
         is anyways subject to be removed because widestrings shouldn't be
         ref. counted anymore (FK) }
       else
-{$ifndef FPC_WINLIKEWIDESTRING}
         if
 {$ifdef MSWINDOWS}
               not winwidestringalloc and
 {$endif MSWINDOWS}
-              (PWideRec(Pointer(S)-WideFirstOff)^.Ref = 1) then
+{$ifdef FPC_WINLIKEWIDESTRING}
+              not IsWideStringConstant(pointer(S))
+{$else}
+              (PWideRec(Pointer(S)-WideFirstOff)^.Ref = 1)
+{$endif FPC_WINLIKEWIDESTRING}
+              then
         begin
           Dec(Pointer(S),WideFirstOff);
           if L*sizeof(WideChar)+WideRecLen>MemSize(Pointer(S)) then
@@ -934,7 +967,6 @@ begin
           Inc(Pointer(S), WideFirstOff);
         end
       else
-{$endif FPC_WINLIKEWIDESTRING}
         begin
           { Reallocation is needed... }
           Temp:=Pointer(NewWideString(L));

tests/webtbs/tw9190.pp

@@ -0,0 +1,32 @@
+var
+  wstr1: widestring;
+  i: longint;
+  w2,w3: widestring;
+
+procedure testproc2(w: widestring);
+begin
+  wstr1:=w;
+end;
+
+procedure testproc1(const w: widestring);
+begin
+  w2:='';
+  testproc2(w);
+  if pointer(w)<>pointer(wstr1) then begin
+    writeln('Test failed!');
+    Halt(1);
+  end;
+  if w<>w3 then begin
+    writeln('Test failed!');
+    Halt(1);
+  end;
+end;
+
+begin
+  setlength(w2, 100000);
+  for i:=1 to length(w2) do
+    w2[i]:=WideChar(Chr(i mod $60 + $20));
+  w3:=w2;
+  wstr1:=w2;
+  testproc1(wstr1);
+end.