mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-25 12:01:50 +02:00
b9f6efc85b
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
818 lines
20 KiB
PHP
818 lines
20 KiB
PHP
{
|
|
$Id$
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 1999-2001 by Florian Klaempfl,
|
|
member of the Free Pascal development team.
|
|
|
|
This file implements support routines for WideStrings with FPC
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************}
|
|
|
|
{
|
|
This file contains the implementation of the WideString type,
|
|
and all things that are needed for it.
|
|
WideString is defined as a 'silent' pwidechar :
|
|
a pwidechar that points to :
|
|
|
|
@-12 : Longint for maximum size;
|
|
@-8 : Longint for size;
|
|
@-4 : Longint for reference count;
|
|
@ : String + Terminating #0;
|
|
Pwidechar(Widestring) is a valid typecast.
|
|
So WS[i] is converted to the address @WS+i-1.
|
|
|
|
Constants should be assigned a reference count of -1
|
|
Meaning that they can't be disposed of.
|
|
}
|
|
|
|
Type
|
|
PWideRec = ^TWideRec;
|
|
TWideRec = Packed Record
|
|
Maxlen,
|
|
len,
|
|
ref : Longint;
|
|
First : WideChar;
|
|
end;
|
|
|
|
Const
|
|
WideRecLen = SizeOf(TWideRec);
|
|
WideFirstOff = SizeOf(TWideRec)-sizeof(WideChar);
|
|
|
|
|
|
{
|
|
Default WideChar <-> Char conversion is to only convert the
|
|
lower 127 chars, all others are translated to spaces.
|
|
|
|
These routines can be overwritten for the Current Locale
|
|
}
|
|
|
|
procedure Wide2AnsiMove(source:pwidechar;dest:pchar;len:longint);
|
|
var
|
|
i : longint;
|
|
begin
|
|
for i:=1to len do
|
|
begin
|
|
if word(source^)<128 then
|
|
dest^:=char(word(source^))
|
|
else
|
|
dest^:=' ';
|
|
inc(dest);
|
|
inc(source);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure Ansi2WideMove(source:pchar;dest:pwidechar;len:longint);
|
|
var
|
|
i : longint;
|
|
begin
|
|
for i:=1to len do
|
|
begin
|
|
if byte(source^)<128 then
|
|
dest^:=widechar(byte(source^))
|
|
else
|
|
dest^:=' ';
|
|
inc(dest);
|
|
inc(source);
|
|
end;
|
|
end;
|
|
|
|
|
|
Type
|
|
TWide2AnsiMove=procedure(source:pwidechar;dest:pchar;len:longint);
|
|
TAnsi2WideMove=procedure(source:pchar;dest:pwidechar;len:longint);
|
|
Const
|
|
Wide2AnsiMoveProc:TWide2AnsiMove=@Wide2AnsiMove;
|
|
Ansi2WideMoveProc:TAnsi2WideMove=@Ansi2WideMove;
|
|
|
|
(*
|
|
Procedure UniqueWideString(Var S : WideString); [Public,Alias : 'FPC_WIDESTR_UNIQUE'];
|
|
{
|
|
Make sure reference count of S is 1,
|
|
using copy-on-write semantics.
|
|
}
|
|
|
|
begin
|
|
end;
|
|
*)
|
|
|
|
|
|
{****************************************************************************
|
|
Internal functions, not in interface.
|
|
****************************************************************************}
|
|
|
|
{$ifdef WideStrDebug}
|
|
Procedure DumpWideRec(S : Pointer);
|
|
begin
|
|
If S=Nil then
|
|
Writeln ('String is nil')
|
|
Else
|
|
Begin
|
|
With PWideRec(S-WideFirstOff)^ do
|
|
begin
|
|
Write ('(Maxlen: ',maxlen);
|
|
Write (' Len:',len);
|
|
Writeln (' Ref: ',ref,')');
|
|
end;
|
|
end;
|
|
end;
|
|
{$endif}
|
|
|
|
|
|
Function NewWideString(Len : Longint) : Pointer;
|
|
{
|
|
Allocate a new WideString on the heap.
|
|
initialize it to zero length and reference count 1.
|
|
}
|
|
Var
|
|
P : Pointer;
|
|
begin
|
|
{ Also add +1 for a terminating zero }
|
|
GetMem(P,Len+Len+WideRecLen);
|
|
If P<>Nil then
|
|
begin
|
|
PWideRec(P)^.Maxlen:=Len; { Maximal length }
|
|
PWideRec(P)^.Len:=0; { Initial length }
|
|
PWideRec(P)^.Ref:=1; { Set reference count }
|
|
PWideRec(P)^.First:=#0; { Terminating #0 }
|
|
inc(p,WideFirstOff); { Points to string now }
|
|
end;
|
|
NewWideString:=P;
|
|
end;
|
|
|
|
|
|
Procedure DisposeWideString(Var S : Pointer);
|
|
{
|
|
Deallocates a WideString From the heap.
|
|
}
|
|
begin
|
|
If S=Nil then
|
|
exit;
|
|
Dec (Longint(S),WideFirstOff);
|
|
FreeMem (S);
|
|
S:=Nil;
|
|
end;
|
|
|
|
|
|
Procedure fpc_WideStr_Decr_Ref (Var S : Pointer);[Public,Alias:'FPC_WIDESTR_DECR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
{
|
|
Decreases the ReferenceCount of a non constant widestring;
|
|
If the reference count is zero, deallocate the string;
|
|
}
|
|
Type
|
|
plongint = ^longint;
|
|
Var
|
|
l : plongint;
|
|
Begin
|
|
{ Zero string }
|
|
If S=Nil then exit;
|
|
{ check for constant strings ...}
|
|
l:=@PWIDEREC(S-WideFirstOff)^.Ref;
|
|
If l^<0 then exit;
|
|
|
|
{ declocked does a MT safe dec and returns true, if the counter is 0 }
|
|
If declocked(l^) then
|
|
{ Ref count dropped to zero }
|
|
DisposeWideString (S); { Remove...}
|
|
{ this pointer is not valid anymore, so set it to zero }
|
|
S:=nil;
|
|
end;
|
|
|
|
{$ifdef hascompilerproc}
|
|
{ alias for internal use }
|
|
Procedure fpc_WideStr_Decr_Ref (Var S : Pointer);[external name 'FPC_WIDESTR_DECR_REF'];
|
|
{$endif compilerproc}
|
|
|
|
Procedure fpc_WideStr_Incr_Ref (Var S : Pointer);[Public,Alias:'FPC_WIDESTR_INCR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
Begin
|
|
If S=Nil then
|
|
exit;
|
|
{ Let's be paranoid : Constant string ??}
|
|
If PWideRec(S-WideFirstOff)^.Ref<0 then exit;
|
|
inclocked(PWideRec(S-WideFirstOff)^.Ref);
|
|
end;
|
|
|
|
|
|
Procedure fpc_WideStr_To_ShortStr (Var S1 : ShortString;S2 : Pointer);[Public, alias: 'FPC_WIDESTR_TO_SHORTSTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
{
|
|
Converts a WideString to a ShortString;
|
|
}
|
|
Var
|
|
Size : Longint;
|
|
begin
|
|
if S2=nil then
|
|
S1:=''
|
|
else
|
|
begin
|
|
Size:=PWideRec(S2-FirstOff)^.Len;
|
|
If Size>high(S1) then
|
|
Size:=high(S1);
|
|
Wide2AnsiMoveProc(PWideChar(S2),PChar(@S1[1]),Size);
|
|
byte(S1[0]):=Size;
|
|
end;
|
|
end;
|
|
|
|
|
|
Procedure fpc_ShortStr_To_WideStr (Var S1 : Pointer; Const S2 : ShortString);[Public, alias: 'FPC_SHORTSTR_TO_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
{
|
|
Converts a ShortString to a WideString;
|
|
}
|
|
Var
|
|
Size : Longint;
|
|
begin
|
|
Size:=Length(S2);
|
|
Setlength (WideString(S1),Size);
|
|
if Size>0 then
|
|
Ansi2WideMoveProc(PChar(@S2[1]),PWideChar(S1),Size);
|
|
end;
|
|
|
|
|
|
Procedure fpc_WideStr_To_AnsiStr (Var S1 : Pointer;S2 : Pointer);[Public, alias: 'FPC_WIDESTR_TO_ANSISTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
{
|
|
Converts a WideString to an AnsiString
|
|
}
|
|
Var
|
|
Size : Longint;
|
|
begin
|
|
if s2=nil then
|
|
s1:=nil
|
|
else
|
|
begin
|
|
Size:=Length(WideString(S2));
|
|
Setlength (AnsiString(S1),Size);
|
|
if Size>0 then
|
|
begin
|
|
Wide2AnsiMoveProc(PWideChar(S2),PChar(S1),Size);
|
|
{ Terminating Zero }
|
|
PChar(S1+Size)^:=#0;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
Procedure fpc_AnsiStr_To_WideStr (Var S1 : Pointer; Const S2 : Pointer);[Public, alias: 'FPC_ANSISTR_TO_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
{
|
|
Converts an AnsiString to a WideString;
|
|
}
|
|
Var
|
|
Size : Longint;
|
|
begin
|
|
if s2=nil then
|
|
s1:=nil
|
|
else
|
|
begin
|
|
Size:=Length(AnsiString(S2));
|
|
Setlength (WideString(S1),Size);
|
|
if Size>0 then
|
|
begin
|
|
Ansi2WideMoveProc(PChar(S2),PWideChar(S1),Size);
|
|
{ Terminating Zero }
|
|
PWideChar(S1+Size*sizeof(WideChar))^:=#0;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ checked against the ansistring routine, 2001-05-27 (FK) }
|
|
Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[Public,Alias:'FPC_WIDESTR_ASSIGN']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
{
|
|
Assigns S2 to S1 (S1:=S2), taking in account reference counts.
|
|
}
|
|
begin
|
|
If S2<>nil then
|
|
If PWideRec(S2-WideFirstOff)^.Ref>0 then
|
|
Inc(PWideRec(S2-WideFirstOff)^.ref);
|
|
{ Decrease the reference count on the old S1 }
|
|
fpc_widestr_decr_ref (S1);
|
|
{ And finally, have S1 pointing to S2 (or its copy) }
|
|
S1:=S2;
|
|
end;
|
|
|
|
{$ifdef hascompilerproc}
|
|
{ alias for internal use }
|
|
Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[external name 'FPC_WIDESTR_ASSIGN'];
|
|
{$endif hascompilerproc}
|
|
|
|
{ checked against the ansistring routine, 2001-05-27 (FK) }
|
|
Procedure fpc_WideStr_Concat (S1,S2 : Pointer;var S3 : Pointer);[Public, alias: 'FPC_WIDESTR_CONCAT']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
{
|
|
Concatenates 2 WideStrings : S1+S2.
|
|
Result Goes to S3;
|
|
}
|
|
Var
|
|
Size,Location : Longint;
|
|
begin
|
|
{ only assign if s1 or s2 is empty }
|
|
if (S1=Nil) then
|
|
fpc_WideStr_Assign(S3,S2)
|
|
else
|
|
if (S2=Nil) then
|
|
fpc_WideStr_Assign(S3,S1)
|
|
else
|
|
begin
|
|
{ create new result }
|
|
fpc_WideStr_Decr_Ref(S3);
|
|
Size:=PWideRec(S2-WideFirstOff)^.Len;
|
|
Location:=Length(WideString(S1));
|
|
SetLength (WideString(S3),Size+Location);
|
|
Move (S1^,S3^,Location*sizeof(WideChar));
|
|
Move (S2^,(S3+location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
|
|
end;
|
|
end;
|
|
|
|
|
|
Procedure fpc_Char_To_WideStr(var S1 : Pointer; c : Char);[Public, alias: 'FPC_CHAR_TO_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
{
|
|
Converts a Char to a WideString;
|
|
}
|
|
begin
|
|
Setlength (WideString(S1),1);
|
|
PWideChar(S1)^:=c;
|
|
{ Terminating Zero }
|
|
PWideChar(S1+sizeof(WideChar))^:=#0;
|
|
end;
|
|
|
|
|
|
Procedure fpc_PChar_To_WideStr(var a : widestring;p : pchar);[Public,Alias : 'FPC_PCHAR_TO_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
Var
|
|
L : Longint;
|
|
begin
|
|
if pointer(a)<>nil then
|
|
begin
|
|
fpc_WideStr_Decr_Ref(Pointer(a));
|
|
pointer(a):=nil;
|
|
end;
|
|
if (not assigned(p)) or (p[0]=#0) Then
|
|
Pointer(a):=nil
|
|
else
|
|
begin
|
|
l:=IndexChar(p^,-1,#0);
|
|
Pointer(a):=NewWidestring(L);
|
|
SetLength(A,L);
|
|
Ansi2WideMoveProc(P,PWideChar(A),L);
|
|
end;
|
|
end;
|
|
|
|
|
|
Procedure fpc_CharArray_To_WideStr(var a : widestring;p : pchar;l:longint);[Public,Alias : 'FPC_CHARARRAY_TO_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
var
|
|
i : longint;
|
|
begin
|
|
if p[0]=#0 Then
|
|
Pointer(a):=nil
|
|
else
|
|
begin
|
|
i:=IndexChar(p^,L,#0);
|
|
Pointer(a):=NewWidestring(i);
|
|
SetLength(a,i);
|
|
Ansi2WideMoveProc(P,PWideChar(A),i);
|
|
end;
|
|
end;
|
|
|
|
|
|
Function fpc_WideStr_Compare(S1,S2 : Pointer): Longint;[Public,Alias : 'FPC_WIDESTR_COMPARE']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
{
|
|
Compares 2 WideStrings;
|
|
The result is
|
|
<0 if S1<S2
|
|
0 if S1=S2
|
|
>0 if S1>S2
|
|
}
|
|
Var
|
|
MaxI,Temp : Longint;
|
|
begin
|
|
if S1=S2 then
|
|
begin
|
|
fpc_WideStr_Compare:=0;
|
|
exit;
|
|
end;
|
|
Maxi:=Length(WideString(S1));
|
|
temp:=Length(WideString(S2));
|
|
If MaxI>Temp then
|
|
MaxI:=Temp;
|
|
Temp:=CompareWord(S1^,S2^,MaxI);
|
|
if temp=0 then
|
|
temp:=Length(WideString(S1))-Length(WideString(S2));
|
|
fpc_WideStr_Compare:=Temp;
|
|
end;
|
|
|
|
|
|
Procedure fpc_WideStr_CheckZero(p : pointer);[Public,Alias : 'FPC_WIDESTR_CHECKZERO']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
begin
|
|
if p=nil then
|
|
HandleErrorFrame(201,get_frame);
|
|
end;
|
|
|
|
|
|
Procedure fpc_WideStr_CheckRange(len,index : longint);[Public,Alias : 'FPC_WIDESTR_RANGECHECK']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
begin
|
|
if (index>len) or (Index<1) then
|
|
HandleErrorFrame(201,get_frame);
|
|
end;
|
|
|
|
{$ifndef INTERNSETLENGTH}
|
|
Procedure SetLength (Var S : WideString; l : Longint);
|
|
{$else INTERNSETLENGTH}
|
|
Procedure fpc_WideStr_SetLength (Var S : WideString; l : Longint);[Public,Alias : 'FPC_WIDESTR_SETLENGTH']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
{$endif INTERNSETLENGTH}
|
|
{
|
|
Sets The length of string S to L.
|
|
Makes sure S is unique, and contains enough room.
|
|
}
|
|
Var
|
|
Temp : Pointer;
|
|
begin
|
|
if (l>0) then
|
|
begin
|
|
if Pointer(S)=nil then
|
|
begin
|
|
{ Need a complete new string...}
|
|
Pointer(s):=NewWideString(l);
|
|
end
|
|
else
|
|
If (PWideRec(Pointer(S)-WideFirstOff)^.Maxlen < L) or
|
|
(PWideRec(Pointer(S)-WideFirstOff)^.Ref <> 1) then
|
|
begin
|
|
{ Reallocation is needed... }
|
|
Temp:=Pointer(NewWideString(L));
|
|
if Length(S)>0 then
|
|
Move(Pointer(S)^,Temp^,L*sizeof(WideChar));
|
|
fpc_WideStr_decr_ref(Pointer(S));
|
|
Pointer(S):=Temp;
|
|
end;
|
|
{ Force nil termination in case it gets shorter }
|
|
PWideChar(Pointer(S)+l*sizeof(WideChar))^:=#0;
|
|
PWideRec(Pointer(S)-WideFirstOff)^.Len:=l;
|
|
end
|
|
else
|
|
begin
|
|
{ Length=0 }
|
|
if Pointer(S)<>nil then
|
|
fpc_WideStr_decr_ref (Pointer(S));
|
|
Pointer(S):=Nil;
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
|
|
{*****************************************************************************
|
|
Public functions, In interface.
|
|
*****************************************************************************}
|
|
|
|
{$ifndef INTERNLENGTH}
|
|
Function Length (Const S : WideString) : Longint;
|
|
{
|
|
Returns the length of an WideString.
|
|
Takes in acount that zero strings are NIL;
|
|
}
|
|
begin
|
|
If Pointer(S)=Nil then
|
|
Length:=0
|
|
else
|
|
Length:=PWideRec(Pointer(S)-WideFirstOff)^.Len;
|
|
end;
|
|
{$endif INTERNLENGTH}
|
|
|
|
{ overloaded version of UniqueString for interface }
|
|
procedure UniqueString(Var S : WideString); [external name 'FPC_WIDESTR_UNIQUE'];
|
|
|
|
Procedure fpc_widestr_Unique(Var S : WideString); [Public,Alias : 'FPC_WIDESTR_UNIQUE']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
{
|
|
Make sure reference count of S is 1,
|
|
using copy-on-write semantics.
|
|
}
|
|
Var
|
|
SNew : Pointer;
|
|
L : Longint;
|
|
begin
|
|
If Pointer(S)=Nil then
|
|
exit;
|
|
if PWideRec(Pointer(S)-WideFirstOff)^.Ref<>1 then
|
|
begin
|
|
L:=PWideRec(Pointer(S)-WideFirstOff)^.len;
|
|
SNew:=NewWideString (L);
|
|
Move (PWideChar(S)^,SNew^,(L+1)*sizeof(WideChar));
|
|
PWideRec(SNew-WideFirstOff)^.len:=L;
|
|
fpc_widestr_decr_ref (Pointer(S)); { Thread safe }
|
|
Pointer(S):=SNew;
|
|
end;
|
|
end;
|
|
|
|
|
|
Function Copy (Const S : WideString; Index,Size : Longint) : WideString;
|
|
var
|
|
ResultAddress : Pointer;
|
|
begin
|
|
ResultAddress:=Nil;
|
|
dec(index);
|
|
if Index < 0 then
|
|
Index := 0;
|
|
{ Check Size. Accounts for Zero-length S, the double check is needed because
|
|
Size can be maxint and will get <0 when adding index }
|
|
if (Size>Length(S)) or
|
|
(Index+Size>Length(S)) then
|
|
Size:=Length(S)-Index;
|
|
If Size>0 then
|
|
begin
|
|
If Index<0 Then
|
|
Index:=0;
|
|
ResultAddress:=Pointer(NewWideString (Size));
|
|
if ResultAddress<>Nil then
|
|
begin
|
|
Move (PWideChar(S)[Index],ResultAddress^,Size*sizeof(WideChar));
|
|
PWideRec(ResultAddress-WideFirstOff)^.Len:=Size;
|
|
PWideChar(ResultAddress+Size*sizeof(WideChar))^:=#0;
|
|
end;
|
|
end;
|
|
Pointer(Copy):=ResultAddress;
|
|
end;
|
|
|
|
|
|
Function Pos (Const Substr : WideString; Const Source : WideString) : Longint;
|
|
var
|
|
i,MaxLen : StrLenInt;
|
|
pc : pwidechar;
|
|
begin
|
|
Pos:=0;
|
|
if Length(SubStr)>0 then
|
|
begin
|
|
MaxLen:=Length(source)-Length(SubStr);
|
|
i:=0;
|
|
pc:=@source[1];
|
|
while (i<=MaxLen) do
|
|
begin
|
|
inc(i);
|
|
if (SubStr[1]=pc^) and
|
|
(CompareWord(Substr[1],pc^,Length(SubStr))=0) then
|
|
begin
|
|
Pos:=i;
|
|
exit;
|
|
end;
|
|
inc(pc);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ Faster version for a widechar alone }
|
|
Function Pos (c : WideChar; Const s : WideString) : Longint;
|
|
var
|
|
i: longint;
|
|
pc : pwidechar;
|
|
begin
|
|
pc:=@s[1];
|
|
for i:=1 to length(s) do
|
|
begin
|
|
if pc^=c then
|
|
begin
|
|
pos:=i;
|
|
exit;
|
|
end;
|
|
inc(pc);
|
|
end;
|
|
pos:=0;
|
|
end;
|
|
|
|
|
|
{ Faster version for a char alone. Must be implemented because }
|
|
{ pos(c: char; const s: shortstring) also exists, so otherwise }
|
|
{ using pos(char,pchar) will always call the shortstring version }
|
|
{ (exact match for first argument), also with $h+ (JM) }
|
|
Function Pos (c : Char; Const s : WideString) : Longint;
|
|
var
|
|
i: longint;
|
|
wc : widechar;
|
|
pc : pwidechar;
|
|
begin
|
|
wc:=c;
|
|
pc:=@s[1];
|
|
for i:=1 to length(s) do
|
|
begin
|
|
if pc^=wc then
|
|
begin
|
|
pos:=i;
|
|
exit;
|
|
end;
|
|
inc(pc);
|
|
end;
|
|
pos:=0;
|
|
end;
|
|
|
|
|
|
|
|
Procedure Delete (Var S : WideString; Index,Size: Longint);
|
|
Var
|
|
LS : Longint;
|
|
begin
|
|
If Length(S)=0 then
|
|
exit;
|
|
if index<=0 then
|
|
begin
|
|
inc(Size,index-1);
|
|
index:=1;
|
|
end;
|
|
LS:=PWideRec(Pointer(S)-WideFirstOff)^.Len;
|
|
if (Index<=LS) and (Size>0) then
|
|
begin
|
|
UniqueString (S);
|
|
if Size+Index>LS then
|
|
Size:=LS-Index+1;
|
|
if Index+Size<=LS then
|
|
begin
|
|
Dec(Index);
|
|
Move(PWideChar(S)[Index+Size],PWideChar(S)[Index],(LS-Index+1)*sizeof(WideChar));
|
|
end;
|
|
Setlength(s,LS-Size);
|
|
end;
|
|
end;
|
|
|
|
|
|
Procedure Insert (Const Source : WideString; Var S : WideString; Index : Longint);
|
|
var
|
|
Temp : WideString;
|
|
LS : Longint;
|
|
begin
|
|
If Length(Source)=0 then
|
|
exit;
|
|
if index <= 0 then
|
|
index := 1;
|
|
Ls:=Length(S);
|
|
if index > LS then
|
|
index := LS+1;
|
|
Dec(Index);
|
|
Pointer(Temp) := NewWideString(Length(Source)+LS);
|
|
SetLength(Temp,Length(Source)+LS);
|
|
If Index>0 then
|
|
move (PWideChar(S)^,PWideChar(Temp)^,Index*sizeof(WideChar));
|
|
Move (PWideChar(Source)^,PWideChar(Temp)[Index],Length(Source)*sizeof(WideChar));
|
|
If (LS-Index)>0 then
|
|
Move(PWideChar(S)[Index],PWideChar(temp)[Length(Source)+index],(LS-Index)*sizeof(WideChar));
|
|
S:=Temp;
|
|
end;
|
|
|
|
|
|
{!!!:Procedure SetString (Var S : WideString; Buf : PWideChar; Len : Longint);
|
|
|
|
begin
|
|
SetLength(S,Len);
|
|
Move (Buf[0],S[1],Len*2);
|
|
end;}
|
|
|
|
Function fpc_Val_Real_WideStr(Const S : WideString; Var Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
Var
|
|
SS : String;
|
|
begin
|
|
fpc_Val_Real_WideStr := 0;
|
|
if length(S) > 255 then
|
|
code := 256
|
|
else
|
|
begin
|
|
SS := S;
|
|
Val(SS,fpc_Val_Real_WideStr,code);
|
|
end;
|
|
end;
|
|
|
|
|
|
Function fpc_Val_UInt_WideStr (Const S : WideString; Var Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
Var
|
|
SS : ShortString;
|
|
begin
|
|
fpc_Val_UInt_WideStr := 0;
|
|
if length(S) > 255 then
|
|
code := 256
|
|
else
|
|
begin
|
|
SS := S;
|
|
Val(SS,fpc_Val_UInt_WideStr,code);
|
|
end;
|
|
end;
|
|
|
|
|
|
Function fpc_Val_SInt_WideStr (DestSize: longint; Const S : WideString; Var Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
Var
|
|
SS : ShortString;
|
|
begin
|
|
fpc_Val_SInt_WideStr:=0;
|
|
if length(S)>255 then
|
|
code:=256
|
|
else
|
|
begin
|
|
SS := S;
|
|
fpc_Val_SInt_WideStr := fpc_Val_SInt_ShortStr(DestSize,SS,Code);
|
|
end;
|
|
end;
|
|
|
|
Function fpc_Val_UInt64_WideStr (Const S : WideString; Var Code : ValSInt): qword; [public, alias:'FPC_VAL_QWORD_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
Var
|
|
SS : ShortString;
|
|
begin
|
|
fpc_Val_UInt64_WideStr:=0;
|
|
if length(S)>255 then
|
|
code:=256
|
|
else
|
|
begin
|
|
SS := S;
|
|
Val(SS,fpc_Val_UInt64_WideStr,Code);
|
|
end;
|
|
end;
|
|
|
|
|
|
Function fpc_Val_SInt64_WideStr (Const S : WideString; Var Code : ValSInt): Int64; [public, alias:'FPC_VAL_INT64_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
Var
|
|
SS : ShortString;
|
|
begin
|
|
fpc_Val_SInt64_WideStr:=0;
|
|
if length(S)>255 then
|
|
code:=256
|
|
else
|
|
begin
|
|
SS := S;
|
|
Val(SS,fpc_Val_SInt64_WideStr,Code);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure fpc_WideStr_Float(d : ValReal;len,fr,rt : longint;var s : WideString);[public,alias:'FPC_WIDESTR_FLOAT']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
var
|
|
ss : shortstring;
|
|
begin
|
|
str_real(len,fr,d,treal_type(rt),ss);
|
|
s:=ss;
|
|
end;
|
|
|
|
|
|
Procedure fpc_WideStr_Cardinal(C : Cardinal;Len : Longint; Var S : WideString);[Public,Alias : 'FPC_WIDESTR_CARDINAL']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
Var
|
|
SS : ShortString;
|
|
begin
|
|
str(C:Len,SS);
|
|
S:=SS;
|
|
end;
|
|
|
|
|
|
|
|
Procedure fpc_WideStr_Longint(L : Longint; Len : Longint; Var S : WideString);[Public,Alias : 'FPC_WIDESTR_LONGINT']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
Var
|
|
SS : ShortString;
|
|
begin
|
|
Str (L:Len,SS);
|
|
S:=SS;
|
|
end;
|
|
|
|
|
|
|
|
{
|
|
$Log$
|
|
Revision 1.11 2001-08-01 15:00:11 jonas
|
|
+ "compproc" helpers
|
|
* renamed several helpers so that their name is the same as their
|
|
"public alias", which should facilitate the conversion of processor
|
|
specific code in the code generator to processor independent code
|
|
* some small fixes to the val_ansistring and val_widestring helpers
|
|
(always immediately exit if the source string is longer than 255
|
|
chars)
|
|
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
|
|
still nil (used to crash, now return resp -1 and 0)
|
|
|
|
Revision 1.10 2001/07/16 12:33:08 jonas
|
|
* fixed wrong public alieases for val(widestring,...)
|
|
|
|
Revision 1.9 2001/07/09 21:15:41 peter
|
|
* Length made internal
|
|
* Add array support for Length
|
|
|
|
Revision 1.8 2001/07/08 21:00:18 peter
|
|
* various widestring updates, it works now mostly without charset
|
|
mapping supported
|
|
|
|
Revision 1.7 2001/05/27 14:28:03 florian
|
|
+ some procedures added
|
|
|
|
Revision 1.6 2000/11/06 23:17:15 peter
|
|
* removed some warnings
|
|
|
|
Revision 1.5 2000/11/06 20:34:24 peter
|
|
* changed ver1_0 defines to temporary defs
|
|
|
|
Revision 1.4 2000/10/21 18:20:17 florian
|
|
* a lot of small changes:
|
|
- setlength is internal
|
|
- win32 graph unit extended
|
|
....
|
|
|
|
Revision 1.3 2000/08/08 22:12:36 sg
|
|
* Implemented WideString helper functions (but they are not tested yet
|
|
due to the lack of full compiler support for WideString/WideChar!)
|
|
|
|
Revision 1.2 2000/07/13 11:33:46 michael
|
|
+ removed logs
|
|
}
|