2
0
Эх сурвалжийг харах

* reallocation of widestrings on windows fixed
* warnings in sstrings.inc fixed

git-svn-id: trunk@500 -

florian 20 жил өмнө
parent
commit
ed95c19399

+ 4 - 4
rtl/inc/sstrings.inc

@@ -57,7 +57,7 @@ end;
 
 
 procedure insert(const source : shortstring;var s : shortstring;index : SizeInt);
 procedure insert(const source : shortstring;var s : shortstring;index : SizeInt);
 var
 var
-  cut,srclen,indexlen : longint;
+  cut,srclen,indexlen : SizeInt;
 begin
 begin
   if index<1 then
   if index<1 then
    index:=1;
    index:=1;
@@ -65,9 +65,9 @@ begin
    index:=length(s)+1;
    index:=length(s)+1;
   indexlen:=Length(s)-Index+1;
   indexlen:=Length(s)-Index+1;
   srclen:=length(Source);
   srclen:=length(Source);
-  if length(source)+length(s)>=sizeof(s) then
+  if SizeInt(length(source)+length(s))>=sizeof(s) then
    begin
    begin
-     cut:=length(source)+length(s)-sizeof(s)+1;
+     cut:=SizeInt(length(source)+length(s))-sizeof(s)+1;
      if cut>indexlen then
      if cut>indexlen then
       begin
       begin
         dec(srclen,cut-indexlen);
         dec(srclen,cut-indexlen);
@@ -84,7 +84,7 @@ end;
 
 
 procedure insert(source : Char;var s : shortstring;index : SizeInt);
 procedure insert(source : Char;var s : shortstring;index : SizeInt);
 var
 var
-  indexlen : longint;
+  indexlen : SizeInt;
 begin
 begin
   if index<1 then
   if index<1 then
    index:=1;
    index:=1;

+ 18 - 3
rtl/inc/wstrings.inc

@@ -117,6 +117,13 @@ end;
                     Internal functions, not in interface.
                     Internal functions, not in interface.
 ****************************************************************************}
 ****************************************************************************}
 
 
+
+procedure WideStringError;
+  begin
+    HandleErrorFrame(204,get_frame);
+  end;
+  
+  
 {$ifdef WideStrDebug}
 {$ifdef WideStrDebug}
 Procedure DumpWideRec(S : Pointer);
 Procedure DumpWideRec(S : Pointer);
 begin
 begin
@@ -149,12 +156,14 @@ begin
   GetMem(P,Len*sizeof(WideChar)+WideRecLen);
   GetMem(P,Len*sizeof(WideChar)+WideRecLen);
 {$endif MSWINDOWS}
 {$endif MSWINDOWS}
   If P<>Nil then
   If P<>Nil then
-   begin
+    begin
      PWideRec(P)^.Len:=0;         { Initial length }
      PWideRec(P)^.Len:=0;         { Initial length }
      PWideRec(P)^.Ref:=1;         { Set reference count }
      PWideRec(P)^.Ref:=1;         { Set reference count }
      PWideRec(P)^.First:=#0;      { Terminating #0 }
      PWideRec(P)^.First:=#0;      { Terminating #0 }
      inc(p,WideFirstOff);         { Points to string now }
      inc(p,WideFirstOff);         { Points to string now }
-   end;
+    end
+  else
+    WideStringError;
   NewWideString:=P;
   NewWideString:=P;
 end;
 end;
 
 
@@ -615,13 +624,19 @@ begin
          { Need a complete new string...}
          { Need a complete new string...}
          Pointer(s):=NewWideString(l);
          Pointer(s):=NewWideString(l);
        end
        end
+      { windows doesn't support reallocing widestrings, this code
+        is anyways subject to be removed because widestrings shouldn't be
+        ref. counted anymore (FK) }
+{$ifndef MSWINDOWS}       
       else if (PWideRec(Pointer(S)-WideFirstOff)^.Ref = 1) then
       else if (PWideRec(Pointer(S)-WideFirstOff)^.Ref = 1) then
         begin
         begin
           Dec(Pointer(S),WideFirstOff);
           Dec(Pointer(S),WideFirstOff);
           if L*sizeof(WideChar)+WideRecLen>MemSize(Pointer(S)) then
           if L*sizeof(WideChar)+WideRecLen>MemSize(Pointer(S)) then
-            reallocmem(pointer(S), L*sizeof(WideChar)+WideRecLen);
+              reallocmem(pointer(S), L*sizeof(WideChar)+WideRecLen);
+          end;
           Inc(Pointer(S), WideFirstOff);
           Inc(Pointer(S), WideFirstOff);
         end
         end
+{$endif MSWINDOWS}        
       else
       else
         begin
         begin
           { Reallocation is needed... }
           { Reallocation is needed... }

+ 3 - 1
rtl/win32/system.pp

@@ -114,12 +114,14 @@ implementation
 { used by wstrings.inc because wstrings.inc is included before sysos.inc
 { used by wstrings.inc because wstrings.inc is included before sysos.inc
   this is put here (FK) }
   this is put here (FK) }
 
 
-function SysAllocStringLen(psz:pointer;len:Integer):pointer;stdcall;
+function SysAllocStringLen(psz:pointer;len:dword):pointer;stdcall;
  external 'oleaut32.dll' name 'SysAllocStringLen';
  external 'oleaut32.dll' name 'SysAllocStringLen';
 
 
 procedure SysFreeString(bstr:pointer);stdcall;
 procedure SysFreeString(bstr:pointer);stdcall;
  external 'oleaut32.dll' name 'SysFreeString';
  external 'oleaut32.dll' name 'SysFreeString';
 
 
+function SysReAllocStringLen(var bstr:pointer;psz: pointer;
+  len:dword): Integer; stdcall;external 'oleaut32.dll' name 'SysReAllocStringLen';
 
 
 
 
 { include system independent routines }
 { include system independent routines }