paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-12 13:49:39 +02:00
Code Issues Packages Projects Releases Wiki Activity

* reallocation of widestrings on windows fixed

Browse Source 
* warnings in sstrings.inc fixed

git-svn-id: trunk@500 -
This commit is contained in:
florian 2005-06-26 08:17:21 +00:00
parent 822f7f0f16
commit ed95c19399
3 changed files with 25 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
rtl/inc/sstrings.inc
View File

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

21
rtl/inc/wstrings.inc
View File

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

4
rtl/win32/system.pp
View File

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