From b178b08ba77dc5207b84643b63f189a79463915a Mon Sep 17 00:00:00 2001
From: florian <florian@freepascal.org>
Date: Wed, 10 Sep 2008 20:14:31 +0000
Subject: [PATCH] Merged revisions 11665-11738 via svnmerge from
http://svn.freepascal.org/svn/fpc/branches/unicodestring
........
r11665 | florian | 2008-08-30 13:30:17 +0200 (Sat, 30 Aug 2008) | 1 line
* continued to work on unicodestring type support
........
r11666 | florian | 2008-08-30 19:02:26 +0200 (Sat, 30 Aug 2008) | 2 lines
* expectloc for wide/ansi/unicode strings is LOC_CONSTANT or LOC_REGISTER now
........
r11667 | florian | 2008-08-30 20:42:37 +0200 (Sat, 30 Aug 2008) | 1 line
* more unicodestring stuff fixed, test results on win32 are already good
........
r11670 | florian | 2008-08-30 23:21:48 +0200 (Sat, 30 Aug 2008) | 2 lines
* first fixes for unix bootstrapping
........
r11683 | ivost | 2008-09-01 12:46:39 +0200 (Mon, 01 Sep 2008) | 2 lines
* fixed 64bit bug in iconvenc.pas
........
r11689 | florian | 2008-09-01 23:12:34 +0200 (Mon, 01 Sep 2008) | 1 line
* fixed several errors when building on unix
........
r11694 | florian | 2008-09-03 20:32:43 +0200 (Wed, 03 Sep 2008) | 1 line
* fixed unix compilation
........
r11695 | florian | 2008-09-03 21:01:04 +0200 (Wed, 03 Sep 2008) | 1 line
* bootstrapping fix
........
r11696 | florian | 2008-09-03 21:07:18 +0200 (Wed, 03 Sep 2008) | 1 line
* more bootstrapping fixed
........
r11698 | florian | 2008-09-03 22:47:54 +0200 (Wed, 03 Sep 2008) | 1 line
+ two missing compiler procs exported
........
r11701 | florian | 2008-09-04 16:42:34 +0200 (Thu, 04 Sep 2008) | 2 lines
+ lazarus project for the linux rtl
........
r11702 | florian | 2008-09-04 16:43:27 +0200 (Thu, 04 Sep 2008) | 2 lines
+ set unicode string procedures
........
r11707 | florian | 2008-09-04 23:23:02 +0200 (Thu, 04 Sep 2008) | 2 lines
* fixed several type casting stuff
........
r11712 | florian | 2008-09-05 22:46:03 +0200 (Fri, 05 Sep 2008) | 1 line
* fixed unicodestring compilation on windows after recent unix changes
........
r11713 | florian | 2008-09-05 23:35:12 +0200 (Fri, 05 Sep 2008) | 1 line
+ UnicodeString support for Variants
........
r11715 | florian | 2008-09-06 20:59:54 +0200 (Sat, 06 Sep 2008) | 1 line
* patch by Martin Schreiber for UnicodeString streaming
........
r11716 | florian | 2008-09-06 22:22:55 +0200 (Sat, 06 Sep 2008) | 2 lines
* fixed test
........
r11717 | florian | 2008-09-07 10:25:51 +0200 (Sun, 07 Sep 2008) | 1 line
* fixed typo when converting tunicodestring to punicodechar
........
r11718 | florian | 2008-09-07 11:29:52 +0200 (Sun, 07 Sep 2008) | 3 lines
* fixed writing of UnicodeString properties
* moved some helper routines to unicode headers
........
r11734 | florian | 2008-09-09 22:38:55 +0200 (Tue, 09 Sep 2008) | 1 line
* fixed bootstrapping
........
r11735 | florian | 2008-09-10 11:25:28 +0200 (Wed, 10 Sep 2008) | 2 lines
* first fixes for persisten unicodestrings
........
r11736 | florian | 2008-09-10 14:31:00 +0200 (Wed, 10 Sep 2008) | 3 lines
Initialized merge tracking via "svnmerge" with revisions "1-11663" from
http://svn.freepascal.org/svn/fpc/trunk
........
r11737 | florian | 2008-09-10 21:06:57 +0200 (Wed, 10 Sep 2008) | 3 lines
* fixed unicodestring <-> variant handling
* fixed unicodestring property reading
........
git-svn-id: trunk@11739 -
---
.gitattributes | 14 +
compiler/ccharset.pas | 254 +++
compiler/cgobj.pas | 14 +-
compiler/cp1251.pas | 2 +-
compiler/cp437.pas | 2 +-
compiler/cp850.pas | 2 +-
compiler/cp866.pas | 2 +-
compiler/cp8859_1.pas | 2 +-
compiler/cp8859_5.pas | 2 +-
compiler/defcmp.pas | 12 +-
compiler/defutil.pas | 22 +
compiler/htypechk.pas | 14 +-
compiler/nadd.pas | 25 +-
compiler/ncal.pas | 3 +-
compiler/ncgcnv.pas | 18 +-
compiler/ncgcon.pas | 15 +-
compiler/ncginl.pas | 2 +-
compiler/ncgld.pas | 2 +-
compiler/ncgmem.pas | 5 +-
compiler/ncgrtti.pas | 9 +-
compiler/ncnv.pas | 17 +-
compiler/ncon.pas | 23 +-
compiler/ninl.pas | 8 +-
compiler/nmem.pas | 5 +-
compiler/nutils.pas | 14 +-
compiler/options.pas | 5 +-
compiler/pdecl.pas | 2 +-
compiler/pinline.pas | 3 +
compiler/ppu.pas | 2 +-
compiler/psystem.pas | 6 +-
compiler/ptconst.pas | 4 +-
compiler/scanner.pas | 2 +-
compiler/symconst.pas | 4 +-
compiler/widestr.pas | 3 +-
packages/iconvenc/src/iconvenc.pas | 167 +-
rtl/inc/compproc.inc | 210 ++-
rtl/inc/rtti.inc | 32 +-
rtl/inc/system.inc | 10 +-
rtl/inc/systemh.inc | 17 +-
rtl/inc/text.inc | 28 +-
rtl/inc/ustringh.inc | 119 ++
rtl/inc/ustrings.inc | 2325 ++++++++++++++++++++++++++++
rtl/inc/variant.inc | 72 +-
rtl/inc/varianth.inc | 18 +
rtl/inc/wstring22h.inc | 108 ++
rtl/inc/wstringh.inc | 57 +-
rtl/inc/wstrings.inc | 1518 +++++++++++++++++-
rtl/inc/wustring22.inc | 2021 ++++++++++++++++++++++++
rtl/inc/wustrings.inc | 1986 ------------------------
rtl/linux/buildrtl.lpi | 64 +
rtl/linux/buildrtl.pp | 20 +
rtl/linux/system.pp | 4 +
rtl/objpas/classes/classes.inc | 29 +-
rtl/objpas/classes/classesh.inc | 10 +-
rtl/objpas/classes/reader.inc | 105 +-
rtl/objpas/classes/writer.inc | 44 +
rtl/objpas/sysutils/sysformt.inc | 4 +
rtl/objpas/typinfo.pp | 94 +-
rtl/unix/cwstring.pp | 12 +-
rtl/win32/buildrtl.lpi | 1 +
rtl/win32/system.pp | 65 +-
tests/test/trtti1.pp | 2 +-
tests/test/tstring10.pp | 27 +
tests/test/tunistr1.pp | 19 +
tests/test/tunistr2.pp | 21 +
tests/test/tunistr4.pp | 92 ++
tests/test/tunistr5.pp | 45 +
tests/test/tunistr6.pp | 397 +++++
tests/test/tunistr7.pp | 47 +
69 files changed, 8007 insertions(+), 2302 deletions(-)
create mode 100644 compiler/ccharset.pas
create mode 100644 rtl/inc/ustringh.inc
create mode 100644 rtl/inc/ustrings.inc
create mode 100644 rtl/inc/wstring22h.inc
create mode 100644 rtl/inc/wustring22.inc
create mode 100644 rtl/linux/buildrtl.lpi
create mode 100644 rtl/linux/buildrtl.pp
create mode 100644 tests/test/tstring10.pp
create mode 100644 tests/test/tunistr1.pp
create mode 100644 tests/test/tunistr2.pp
create mode 100644 tests/test/tunistr4.pp
create mode 100644 tests/test/tunistr5.pp
create mode 100644 tests/test/tunistr6.pp
create mode 100644 tests/test/tunistr7.pp
diff --git a/.gitattributes b/.gitattributes
index da45c11009..9bacf83d65 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -106,6 +106,7 @@ compiler/avr/rgcpu.pas svneol=native#text/plain
compiler/browcol.pas svneol=native#text/plain
compiler/bsdcompile -text
compiler/catch.pas svneol=native#text/plain
+compiler/ccharset.pas svneol=native#text/plain
compiler/cclasses.pas svneol=native#text/plain
compiler/cfidwarf.pas svneol=native#text/plain
compiler/cfileutl.pas svneol=native#text/plain
@@ -5383,14 +5384,18 @@ rtl/inc/threadvr.inc svneol=native#text/plain
rtl/inc/typefile.inc svneol=native#text/plain
rtl/inc/ucomplex.pp svneol=native#text/plain
rtl/inc/ufloat128.pp svneol=native#text/plain
+rtl/inc/ustringh.inc svneol=native#text/plain
+rtl/inc/ustrings.inc svneol=native#text/plain
rtl/inc/varerror.inc svneol=native#text/plain
rtl/inc/variant.inc svneol=native#text/plain
rtl/inc/varianth.inc svneol=native#text/plain
rtl/inc/variants.pp svneol=native#text/plain
rtl/inc/video.inc svneol=native#text/plain
rtl/inc/videoh.inc svneol=native#text/plain
+rtl/inc/wstring22h.inc svneol=native#text/plain
rtl/inc/wstringh.inc svneol=native#text/plain
rtl/inc/wstrings.inc -text
+rtl/inc/wustring22.inc svneol=native#text/plain
rtl/inc/wustrings.inc svneol=native#text/plain
rtl/linux/Makefile svneol=native#text/plain
rtl/linux/Makefile.fpc svneol=native#text/plain
@@ -5406,6 +5411,8 @@ rtl/linux/arm/syscall.inc svneol=native#text/plain
rtl/linux/arm/syscallh.inc svneol=native#text/plain
rtl/linux/arm/sysnr.inc svneol=native#text/plain
rtl/linux/arm/ucprt0.as svneol=native#text/plain
+rtl/linux/buildrtl.lpi svneol=native#text/plain
+rtl/linux/buildrtl.pp svneol=native#text/plain
rtl/linux/bunxsysc.inc svneol=native#text/plain
rtl/linux/errno.inc svneol=native#text/plain
rtl/linux/errnostr.inc -text
@@ -7820,6 +7827,7 @@ tests/test/tsetsize.pp svneol=native#text/plain
tests/test/tstack.pp svneol=native#text/plain
tests/test/tstprocv.pp svneol=native#text/plain
tests/test/tstring1.pp svneol=native#text/plain
+tests/test/tstring10.pp svneol=native#text/plain
tests/test/tstring2.pp svneol=native#text/plain
tests/test/tstring3.pp svneol=native#text/plain
tests/test/tstring4.pp svneol=native#text/plain
@@ -7833,6 +7841,12 @@ tests/test/tstrreal2.pp svneol=native#text/plain
tests/test/tstrreal3.pp -text
tests/test/tsubdecl.pp svneol=native#text/plain
tests/test/tunaligned1.pp svneol=native#text/plain
+tests/test/tunistr1.pp svneol=native#text/plain
+tests/test/tunistr2.pp svneol=native#text/plain
+tests/test/tunistr4.pp svneol=native#text/plain
+tests/test/tunistr5.pp svneol=native#text/plain
+tests/test/tunistr6.pp svneol=native#text/plain
+tests/test/tunistr7.pp svneol=native#text/plain
tests/test/tunit1.pp svneol=native#text/plain
tests/test/tunit2.pp svneol=native#text/plain
tests/test/tunit3.pp svneol=native#text/plain
diff --git a/compiler/ccharset.pas b/compiler/ccharset.pas
new file mode 100644
index 0000000000..258a0359d2
--- /dev/null
+++ b/compiler/ccharset.pas
@@ -0,0 +1,254 @@
+{
+ This file is part of the Free Pascal run time library.
+ Copyright (c) 2000 by Florian Klaempfl
+ member of the Free Pascal development team.
+
+ This unit implements several classes for charset conversions
+
+ 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 unit is included temporarily for 2.2 bootstrapping and can be
+ removed after the next release after 2.2.2 }
+{$mode objfpc}
+unit ccharset;
+
+ interface
+
+ type
+ tunicodechar = word;
+ tunicodestring = ^tunicodechar;
+
+ tcsconvert = class
+ // !!!!!!1constructor create;
+ end;
+
+ tunicodecharmappingflag = (umf_noinfo,umf_leadbyte,umf_undefined,
+ umf_unused);
+
+ punicodecharmapping = ^tunicodecharmapping;
+ tunicodecharmapping = record
+ unicode : tunicodechar;
+ flag : tunicodecharmappingflag;
+ reserved : byte;
+ end;
+
+ punicodemap = ^tunicodemap;
+ tunicodemap = record
+ cpname : string[20];
+ map : punicodecharmapping;
+ lastchar : longint;
+ next : punicodemap;
+ internalmap : boolean;
+ end;
+
+ tcp2unicode = class(tcsconvert)
+ end;
+
+ function loadunicodemapping(const cpname,f : string) : punicodemap;
+ procedure registermapping(p : punicodemap);
+ function getmap(const s : string) : punicodemap;
+ function mappingavailable(const s : string) : boolean;
+ function getunicode(c : char;p : punicodemap) : tunicodechar;
+ function getascii(c : tunicodechar;p : punicodemap) : string;
+
+ implementation
+
+ var
+ mappings : punicodemap;
+
+ function loadunicodemapping(const cpname,f : string) : punicodemap;
+
+ var
+ data : punicodecharmapping;
+ datasize : longint;
+ t : text;
+ s,hs : string;
+ scanpos,charpos,unicodevalue : longint;
+ code : word;
+ flag : tunicodecharmappingflag;
+ p : punicodemap;
+ lastchar : longint;
+
+ begin
+ lastchar:=-1;
+ loadunicodemapping:=nil;
+ datasize:=256;
+ getmem(data,sizeof(tunicodecharmapping)*datasize);
+ assign(t,f);
+ {$I-}
+ reset(t);
+ {$I+}
+ if ioresult<>0 then
+ begin
+ freemem(data,sizeof(tunicodecharmapping)*datasize);
+ exit;
+ end;
+ while not(eof(t)) do
+ begin
+ readln(t,s);
+ if (s[1]='0') and (s[2]='x') then
+ begin
+ flag:=umf_unused;
+ scanpos:=3;
+ hs:='$';
+ while s[scanpos] in ['0'..'9','A'..'F','a'..'f'] do
+ begin
+ hs:=hs+s[scanpos];
+ inc(scanpos);
+ end;
+ val(hs,charpos,code);
+ if code<>0 then
+ begin
+ freemem(data,sizeof(tunicodecharmapping)*datasize);
+ close(t);
+ exit;
+ end;
+ while not(s[scanpos] in ['0','#']) do
+ inc(scanpos);
+ if s[scanpos]='#' then
+ begin
+ { special char }
+ unicodevalue:=$ffff;
+ hs:=copy(s,scanpos,length(s)-scanpos+1);
+ if hs='#DBCS LEAD BYTE' then
+ flag:=umf_leadbyte;
+ end
+ else
+ begin
+ { C hex prefix }
+ inc(scanpos,2);
+ hs:='$';
+ while s[scanpos] in ['0'..'9','A'..'F','a'..'f'] do
+ begin
+ hs:=hs+s[scanpos];
+ inc(scanpos);
+ end;
+ val(hs,unicodevalue,code);
+ if code<>0 then
+ begin
+ freemem(data,sizeof(tunicodecharmapping)*datasize);
+ close(t);
+ exit;
+ end;
+ if charpos>datasize then
+ begin
+ { allocate 1024 bytes more because }
+ { if we need more than 256 entries it's }
+ { probably a mbcs with a lot of }
+ { entries }
+ datasize:=charpos+1024;
+ reallocmem(data,sizeof(tunicodecharmapping)*datasize);
+ end;
+ flag:=umf_noinfo;
+ end;
+ data[charpos].flag:=flag;
+ data[charpos].unicode:=unicodevalue;
+ if charpos>lastchar then
+ lastchar:=charpos;
+ end;
+ end;
+ close(t);
+ new(p);
+ p^.lastchar:=lastchar;
+ p^.cpname:=cpname;
+ p^.internalmap:=false;
+ p^.next:=nil;
+ p^.map:=data;
+ loadunicodemapping:=p;
+ end;
+
+ procedure registermapping(p : punicodemap);
+
+ begin
+ p^.next:=mappings;
+ mappings:=p;
+ end;
+
+ function getmap(const s : string) : punicodemap;
+
+ var
+ hp : punicodemap;
+
+ const
+ mapcache : string = '';
+ mapcachep : punicodemap = nil;
+
+ begin
+ if (mapcache=s) and assigned(mapcachep) and (mapcachep^.cpname=s) then
+ begin
+ getmap:=mapcachep;
+ exit;
+ end;
+ hp:=mappings;
+ while assigned(hp) do
+ begin
+ if hp^.cpname=s then
+ begin
+ getmap:=hp;
+ mapcache:=s;
+ mapcachep:=hp;
+ exit;
+ end;
+ hp:=hp^.next;
+ end;
+ getmap:=nil;
+ end;
+
+ function mappingavailable(const s : string) : boolean;
+
+ begin
+ mappingavailable:=getmap(s)<>nil;
+ end;
+
+ function getunicode(c : char;p : punicodemap) : tunicodechar;
+
+ begin
+ if ord(c)<=p^.lastchar then
+ getunicode:=p^.map[ord(c)].unicode
+ else
+ getunicode:=0;
+ end;
+
+ function getascii(c : tunicodechar;p : punicodemap) : string;
+
+ var
+ i : longint;
+
+ begin
+ { at least map to space }
+ getascii:=#32;
+ for i:=0 to p^.lastchar do
+ if p^.map[i].unicode=c then
+ begin
+ if i<256 then
+ getascii:=chr(i)
+ else
+ getascii:=chr(i div 256)+chr(i mod 256);
+ exit;
+ end;
+ end;
+
+ var
+ hp : punicodemap;
+
+initialization
+ mappings:=nil;
+finalization
+ while assigned(mappings) do
+ begin
+ hp:=mappings^.next;
+ if not(mappings^.internalmap) then
+ begin
+ freemem(mappings^.map);
+ dispose(mappings);
+ end;
+ mappings:=hp;
+ end;
+end.
diff --git a/compiler/cgobj.pas b/compiler/cgobj.pas
index 7bea0c7996..e9be0183ce 100644
--- a/compiler/cgobj.pas
+++ b/compiler/cgobj.pas
@@ -3112,13 +3112,15 @@ implementation
paramanager.getintparaloc(pocall_default,1,cgpara1);
paramanager.getintparaloc(pocall_default,2,cgpara2);
if is_interfacecom(t) then
- incrfunc:='FPC_INTF_INCR_REF'
+ incrfunc:='FPC_INTF_INCR_REF'
else if is_ansistring(t) then
- incrfunc:='FPC_ANSISTR_INCR_REF'
+ incrfunc:='FPC_ANSISTR_INCR_REF'
else if is_widestring(t) then
- incrfunc:='FPC_WIDESTR_INCR_REF'
+ incrfunc:='FPC_WIDESTR_INCR_REF'
+ else if is_unicodestring(t) then
+ incrfunc:='FPC_UNICODESTR_INCR_REF'
else if is_dynamic_array(t) then
- incrfunc:='FPC_DYNARRAY_INCR_REF'
+ incrfunc:='FPC_DYNARRAY_INCR_REF'
else
incrfunc:='';
{ call the special incr function or the generic addref }
@@ -3174,6 +3176,8 @@ implementation
decrfunc:='FPC_ANSISTR_DECR_REF'
else if is_widestring(t) then
decrfunc:='FPC_WIDESTR_DECR_REF'
+ else if is_unicodestring(t) then
+ decrfunc:='FPC_UNICODESTR_DECR_REF'
else if is_dynamic_array(t) then
begin
decrfunc:='FPC_DYNARRAY_DECR_REF';
@@ -3234,6 +3238,7 @@ implementation
paramanager.getintparaloc(pocall_default,2,cgpara2);
if is_ansistring(t) or
is_widestring(t) or
+ is_unicodestring(t) or
is_interfacecom(t) or
is_dynamic_array(t) then
a_load_const_ref(list,OS_ADDR,0,ref)
@@ -3266,6 +3271,7 @@ implementation
paramanager.getintparaloc(pocall_default,2,cgpara2);
if is_ansistring(t) or
is_widestring(t) or
+ is_unicodestring(t) or
is_interfacecom(t) then
begin
g_decrrefcount(list,t,ref);
diff --git a/compiler/cp1251.pas b/compiler/cp1251.pas
index a2534fb531..b5f99074ea 100644
--- a/compiler/cp1251.pas
+++ b/compiler/cp1251.pas
@@ -6,7 +6,7 @@ unit cp1251;
implementation
uses
- charset;
+ {$ifdef VER2_2}ccharset{$else VER2_2}charset{$endif VER2_2};
const
map : array[0..255] of tunicodecharmapping = (
diff --git a/compiler/cp437.pas b/compiler/cp437.pas
index a8ca25d3d3..144c854fcd 100644
--- a/compiler/cp437.pas
+++ b/compiler/cp437.pas
@@ -6,7 +6,7 @@ unit cp437;
implementation
uses
- charset;
+ {$ifdef VER2_2}ccharset{$else VER2_2}charset{$endif VER2_2};
const
map : array[0..255] of tunicodecharmapping = (
diff --git a/compiler/cp850.pas b/compiler/cp850.pas
index 0a47f68268..51b3a3d1c8 100644
--- a/compiler/cp850.pas
+++ b/compiler/cp850.pas
@@ -6,7 +6,7 @@ unit cp850;
implementation
uses
- charset;
+ {$ifdef VER2_2}ccharset{$else VER2_2}charset{$endif VER2_2};
const
map : array[0..255] of tunicodecharmapping = (
diff --git a/compiler/cp866.pas b/compiler/cp866.pas
index 435528b133..1279ae51a1 100644
--- a/compiler/cp866.pas
+++ b/compiler/cp866.pas
@@ -6,7 +6,7 @@ unit cp866;
implementation
uses
- charset;
+ {$ifdef VER2_2}ccharset{$else VER2_2}charset{$endif VER2_2};
const
map : array[0..255] of tunicodecharmapping = (
diff --git a/compiler/cp8859_1.pas b/compiler/cp8859_1.pas
index 5b01d1664b..ae36fe3c18 100644
--- a/compiler/cp8859_1.pas
+++ b/compiler/cp8859_1.pas
@@ -6,7 +6,7 @@ unit cp8859_1;
implementation
uses
- charset;
+ {$ifdef VER2_2}ccharset{$else VER2_2}charset{$endif VER2_2};
const
map : array[0..255] of tunicodecharmapping = (
diff --git a/compiler/cp8859_5.pas b/compiler/cp8859_5.pas
index e859ff0963..cc8f0c27f7 100644
--- a/compiler/cp8859_5.pas
+++ b/compiler/cp8859_5.pas
@@ -6,7 +6,7 @@ unit cp8859_5;
implementation
uses
- charset;
+ {$ifdef VER2_2}ccharset{$else VER2_2}charset{$endif VER2_2};
const
map : array[0..255] of tunicodecharmapping = (
diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas
index 459aa68c5d..4518192aa9 100644
--- a/compiler/defcmp.pas
+++ b/compiler/defcmp.pas
@@ -413,7 +413,7 @@ implementation
else if (cs_ansistrings in current_settings.localswitches) and
(tstringdef(def_to).stringtype=st_ansistring) then
eq:=te_equal
- else if tstringdef(def_to).stringtype=st_widestring then
+ else if tstringdef(def_to).stringtype in [st_widestring,st_unicodestring] then
eq:=te_convert_l3
else
eq:=te_convert_l1;
@@ -425,7 +425,7 @@ implementation
begin
if is_ansistring(def_to) then
eq:=te_convert_l1
- else if is_widestring(def_to) then
+ else if is_widestring(def_to) or is_unicodestring(def_to) then
eq:=te_convert_l3
else
eq:=te_convert_l2;
@@ -446,7 +446,7 @@ implementation
else
eq:=te_convert_l2;
end
- else if is_widestring(def_to) then
+ else if is_widestring(def_to) or is_unicodestring(def_to) then
eq:=te_convert_l3
else
eq:=te_convert_l2;
@@ -458,7 +458,7 @@ implementation
if is_widechararray(def_from) or is_open_widechararray(def_from) then
begin
doconv:=tc_chararray_2_string;
- if is_widestring(def_to) then
+ if is_widestring(def_to) or is_unicodestring(def_to) then
eq:=te_convert_l1
else
{ size of widechar array is double due the sizeof a widechar }
@@ -490,7 +490,7 @@ implementation
else if is_pwidechar(def_from) then
begin
doconv:=tc_pwchar_2_string;
- if is_widestring(def_to) then
+ if is_widestring(def_to) or is_unicodestring(def_to) then
eq:=te_convert_l1
else
eq:=te_convert_l3;
@@ -909,7 +909,7 @@ implementation
else
{ pwidechar(widestring) }
if is_pwidechar(def_to) and
- is_widestring(def_from) then
+ is_wide_or_unicode_string(def_from) then
begin
doconv:=tc_ansistring_2_pchar;
eq:=te_convert_l1;
diff --git a/compiler/defutil.pas b/compiler/defutil.pas
index 0469d910b0..98c9fc11dc 100644
--- a/compiler/defutil.pas
+++ b/compiler/defutil.pas
@@ -165,6 +165,12 @@ interface
{# returns true if p is a wide string type }
function is_widestring(p : tdef) : boolean;
+ {# true if p is an unicode string def }
+ function is_unicodestring(p : tdef) : boolean;
+
+ {# returns true if p is a wide or unicode string type }
+ function is_wide_or_unicode_string(p : tdef) : boolean;
+
{# Returns true if p is a short string type }
function is_shortstring(p : tdef) : boolean;
@@ -577,6 +583,22 @@ implementation
end;
+ { true if p is an wide string def }
+ function is_wide_or_unicode_string(p : tdef) : boolean;
+ begin
+ is_wide_or_unicode_string:=(p.typ=stringdef) and
+ (tstringdef(p).stringtype in [st_widestring,st_unicodestring]);
+ end;
+
+
+ { true if p is an unicode string def }
+ function is_unicodestring(p : tdef) : boolean;
+ begin
+ is_unicodestring:=(p.typ=stringdef) and
+ (tstringdef(p).stringtype=st_unicodestring);
+ end;
+
+
{ true if p is an short string def }
function is_shortstring(p : tdef) : boolean;
begin
diff --git a/compiler/htypechk.pas b/compiler/htypechk.pas
index b7e548742f..5eec724079 100644
--- a/compiler/htypechk.pas
+++ b/compiler/htypechk.pas
@@ -1541,7 +1541,7 @@ implementation
) or
(
is_widechar(p.resultdef) and
- is_widestring(def_to)
+ (is_widestring(def_to) or is_unicodestring(def_to))
) then
eq:=te_equal
end;
@@ -2238,7 +2238,7 @@ implementation
(tve_single,tve_dblcurrency,tve_extended,
tve_dblcurrency,tve_dblcurrency,tve_extended);
variantstringdef_cl: array[tstringtype] of tvariantequaltype =
- (tve_sstring,tve_astring,tve_astring,tve_wstring,tve_unicodestring);
+ (tve_sstring,tve_astring,tve_astring,tve_wstring,tve_ustring);
begin
case def.typ of
orddef:
@@ -2437,9 +2437,9 @@ implementation
else if (currvcl=tve_boolformal) or
(bestvcl=tve_boolformal) then
if (currvcl=tve_boolformal) then
- result:=ord(bestvcl in [tve_chari64,tve_sstring,tve_astring,tve_wstring])
+ result:=ord(bestvcl in [tve_chari64,tve_sstring,tve_astring,tve_wstring,tve_ustring])
else
- result:=-ord(currvcl in [tve_chari64,tve_sstring,tve_astring,tve_wstring])
+ result:=-ord(currvcl in [tve_chari64,tve_sstring,tve_astring,tve_wstring,tve_ustring])
{ byte is better than everything else (we assume both aren't byte, }
{ since there's only one parameter and that one can't be the same) }
else if (currvcl=tve_byte) or
@@ -2497,7 +2497,11 @@ implementation
{ widestring is better than everything left }
else if (currvcl=tve_wstring) or
(bestvcl=tve_wstring) then
- result:=1-2*ord(bestvcl=tve_wstring);
+ result:=1-2*ord(bestvcl=tve_wstring)
+ { unicodestring is better than everything left }
+ else if (currvcl=tve_ustring) or
+ (bestvcl=tve_ustring) then
+ result:=1-2*ord(bestvcl=tve_ustring);
{ all possibilities should have been checked now }
if (result=-5) then
diff --git a/compiler/nadd.pas b/compiler/nadd.pas
index 79efa1e6b2..a7a3ad30f3 100644
--- a/compiler/nadd.pas
+++ b/compiler/nadd.pas
@@ -546,11 +546,11 @@ implementation
{ stringconstn only }
{ widechars are converted above to widestrings too }
- { this isn't veryy efficient, but I don't think }
+ { this isn't ver y efficient, but I don't think }
{ that it does matter that much (FK) }
if (lt=stringconstn) and (rt=stringconstn) and
- (tstringconstnode(left).cst_type=cst_widestring) and
- (tstringconstnode(right).cst_type=cst_widestring) then
+ (tstringconstnode(left).cst_type in [cst_widestring,cst_unicodestring]) and
+ (tstringconstnode(right).cst_type in [cst_widestring,cst_unicodestring]) then
begin
initwidestring(ws1);
initwidestring(ws2);
@@ -835,6 +835,8 @@ implementation
if is_constnode(right) and is_constnode(left) and
(is_widestring(right.resultdef) or
is_widestring(left.resultdef) or
+ is_unicodestring(right.resultdef) or
+ is_unicodestring(left.resultdef) or
is_widechar(right.resultdef) or
is_widechar(left.resultdef)) then
begin
@@ -1419,8 +1421,13 @@ implementation
begin
if (nodetype in [addn,equaln,unequaln,lten,gten,ltn,gtn]) then
begin
+ { Is there a unicodestring? }
+ if is_unicodestring(rd) or is_unicodestring(ld) then
+ strtype:= st_unicodestring
+ else
{ Is there a widestring? }
if is_widestring(rd) or is_widestring(ld) or
+ is_unicodestring(rd) or is_unicodestring(ld) or
is_pwidechar(rd) or is_widechararray(rd) or is_widechar(rd) or is_open_widechararray(rd) or
is_pwidechar(ld) or is_widechararray(ld) or is_widechar(ld) or is_open_widechararray(ld) then
strtype:= st_widestring
@@ -1456,6 +1463,13 @@ implementation
if not(is_widestring(ld)) then
inserttypeconv(left,cwidestringtype);
end;
+ st_unicodestring :
+ begin
+ if not(is_unicodestring(rd)) then
+ inserttypeconv(right,cunicodestringtype);
+ if not(is_unicodestring(ld)) then
+ inserttypeconv(left,cunicodestringtype);
+ end;
st_ansistring :
begin
if not(is_ansistring(rd)) then
@@ -2520,6 +2534,11 @@ implementation
{ this is only for add, the comparisaion is handled later }
expectloc:=LOC_REGISTER;
end
+ else if is_unicodestring(ld) then
+ begin
+ { this is only for add, the comparisaion is handled later }
+ expectloc:=LOC_REGISTER;
+ end
else if is_ansistring(ld) then
begin
{ this is only for add, the comparisaion is handled later }
diff --git a/compiler/ncal.pas b/compiler/ncal.pas
index ff9dae62cc..419783cc80 100644
--- a/compiler/ncal.pas
+++ b/compiler/ncal.pas
@@ -2772,7 +2772,8 @@ implementation
else
{ ansi/widestrings must be registered, so we can dispose them }
if is_ansistring(resultdef) or
- is_widestring(resultdef) then
+ is_widestring(resultdef) or
+ is_unicodestring(resultdef) then
begin
expectloc:=LOC_REFERENCE;
end
diff --git a/compiler/ncgcnv.pas b/compiler/ncgcnv.pas
index 734667c020..6649e927ae 100644
--- a/compiler/ncgcnv.pas
+++ b/compiler/ncgcnv.pas
@@ -148,6 +148,8 @@ interface
location.register:=cg.getaddressregister(current_asmdata.CurrAsmList);
cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,left.location.reference,location.register);
end;
+ cst_widestring,
+ cst_unicodestring,
cst_ansistring :
begin
if tstringconstnode(left).len=0 then
@@ -167,20 +169,8 @@ interface
{!!!!!!!}
internalerror(8888);
end;
- cst_widestring:
- begin
- if tstringconstnode(left).len=0 then
- begin
- reference_reset(hr);
- hr.symbol:=current_asmdata.RefAsmSymbol('FPC_EMPTYCHAR');
- location.register:=cg.getaddressregister(current_asmdata.CurrAsmList);
- cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,hr,location.register);
- end
- else
- begin
- location_copy(location,left.location);
- end;
- end;
+ else
+ internalerror(200808241);
end;
end;
diff --git a/compiler/ncgcon.pas b/compiler/ncgcon.pas
index 9e9254be0e..11bc914709 100644
--- a/compiler/ncgcon.pas
+++ b/compiler/ncgcon.pas
@@ -270,7 +270,7 @@ implementation
pooltype: TConstPoolType;
pool: THashSet;
entry: PHashSetItem;
-
+
const
PoolMap: array[tconststringtype] of TConstPoolType = (
sp_conststr,
@@ -282,7 +282,7 @@ implementation
);
begin
{ for empty ansistrings we could return a constant 0 }
- if (cst_type in [cst_ansistring,cst_widestring]) and (len=0) then
+ if (cst_type in [cst_ansistring,cst_widestring,cst_unicodestring]) and (len=0) then
begin
location_reset(location,LOC_CONSTANT,OS_ADDR);
location.value:=0;
@@ -295,7 +295,7 @@ implementation
if current_asmdata.ConstPools[pooltype] = nil then
current_asmdata.ConstPools[pooltype] := THashSet.Create(64, True, False);
pool := current_asmdata.ConstPools[pooltype];
-
+
if cst_type in [cst_widestring, cst_unicodestring] then
entry := pool.FindOrAdd(pcompilerwidestring(value_str)^.data, len*cwidechartype.size)
else
@@ -311,7 +311,7 @@ implementation
entry^.Data := lastlabel;
maybe_new_object_file(current_asmdata.asmlists[al_typedconsts]);
if (len=0) or
- not(cst_type in [cst_ansistring,cst_widestring]) then
+ not(cst_type in [cst_ansistring,cst_widestring,cst_unicodestring]) then
new_section(current_asmdata.asmlists[al_typedconsts],sec_rodata_norel,lastlabel.name,const_align(sizeof(pint)))
else
new_section(current_asmdata.asmlists[al_typedconsts],sec_rodata,lastlabel.name,const_align(sizeof(pint)));
@@ -321,7 +321,7 @@ implementation
begin
if len=0 then
InternalError(2008032301) { empty string should be handled above }
- else
+ else
begin
current_asmdata.getdatalabel(l1);
current_asmdata.asmlists[al_typedconsts].concat(Tai_label.Create(l1));
@@ -342,6 +342,7 @@ implementation
current_asmdata.asmlists[al_typedconsts].concat(Tai_string.Create_pchar(pc,len+1));
end;
end;
+ cst_unicodestring,
cst_widestring:
begin
if len=0 then
@@ -353,7 +354,7 @@ implementation
{ we use always UTF-16 coding for constants }
{ at least for now }
{ Consts.concat(Tai_const.Create_8bit(2)); }
- if tf_winlikewidestring in target_info.flags then
+ if (cst_type=cst_widestring) and (tf_winlikewidestring in target_info.flags) then
current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_32bit(len*cwidechartype.size))
else
begin
@@ -401,7 +402,7 @@ implementation
end;
end;
end;
- if cst_type in [cst_ansistring, cst_widestring] then
+ if cst_type in [cst_ansistring, cst_widestring, cst_unicodestring] then
begin
location_reset(location, LOC_REGISTER, OS_ADDR);
reference_reset_symbol(href, lab_str, 0);
diff --git a/compiler/ncginl.pas b/compiler/ncginl.pas
index 322fe09875..7508c22cf5 100644
--- a/compiler/ncginl.pas
+++ b/compiler/ncginl.pas
@@ -358,7 +358,7 @@ implementation
hregister:=cg.makeregsize(current_asmdata.CurrAsmList,left.location.register,OS_INT);
cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_INT,OS_INT,href,hregister);
end;
- if is_widestring(left.resultdef) then
+ if is_widestring(left.resultdef) or is_unicodestring(left.resultdef) then
cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SHR,OS_INT,1,hregister);
cg.a_label(current_asmdata.CurrAsmList,lengthlab);
location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
diff --git a/compiler/ncgld.pas b/compiler/ncgld.pas
index 988ad244c5..3d8066f316 100644
--- a/compiler/ncgld.pas
+++ b/compiler/ncgld.pas
@@ -1073,7 +1073,7 @@ implementation
freetemp:=false;
end
else
- if is_widestring(lt) then
+ if is_widestring(lt) or is_unicodestring(lt) then
begin
vtype:=vtWideString;
freetemp:=false;
diff --git a/compiler/ncgmem.pas b/compiler/ncgmem.pas
index 77790e8030..e29b53987c 100644
--- a/compiler/ncgmem.pas
+++ b/compiler/ncgmem.pas
@@ -642,7 +642,8 @@ implementation
{ an ansistring needs to be dereferenced }
if is_ansistring(left.resultdef) or
- is_widestring(left.resultdef) then
+ is_widestring(left.resultdef) or
+ is_unicodestring(left.resultdef) then
begin
if nf_callunique in flags then
internalerror(200304236);
@@ -763,6 +764,7 @@ implementation
begin
case tstringdef(left.resultdef).stringtype of
{ it's the same for ansi- and wide strings }
+ st_unicodestring,
st_widestring,
st_ansistring:
begin
@@ -926,6 +928,7 @@ implementation
begin
case tstringdef(left.resultdef).stringtype of
{ it's the same for ansi- and wide strings }
+ st_unicodestring,
st_widestring,
st_ansistring:
begin
diff --git a/compiler/ncgrtti.pas b/compiler/ncgrtti.pas
index f900ab57d4..fcac8726b1 100644
--- a/compiler/ncgrtti.pas
+++ b/compiler/ncgrtti.pas
@@ -372,6 +372,11 @@ implementation
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkWString));
write_rtti_name(def);
end;
+ st_unicodestring:
+ begin
+ current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkUString));
+ write_rtti_name(def);
+ end;
st_longstring:
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkLString));
@@ -976,7 +981,7 @@ implementation
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(4));
asmlists[al_rtti].concat(Tai_const.create_32bit(syms[i].value));
if (tf_requires_proper_alignment in target_info.flags) then
- current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
+ current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
asmlists[al_rtti].concat(Tai_const.create_sym_offset(mainrtti,st+offsets[i]));
end;
end;
@@ -1069,7 +1074,7 @@ implementation
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(4));
asmlists[al_rtti].concat(Tai_const.create_32bit(syms[i].value));
if (tf_requires_proper_alignment in target_info.flags) then
- current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
+ current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
asmlists[al_rtti].concat(Tai_const.create_sym_offset(mainrtti,st+offsets[i]));
end;
asmlists[al_rtti].concat(Tai_symbol_end.create(rttilab));
diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas
index 3a59f3e46c..fbf0814412 100644
--- a/compiler/ncnv.pas
+++ b/compiler/ncnv.pas
@@ -917,12 +917,12 @@ implementation
{ we can't do widechar to ansichar conversions at compile time, since }
{ this maps all non-ascii chars to '?' -> loses information }
if (left.nodetype=ordconstn) and
- ((tstringdef(resultdef).stringtype=st_widestring) or
+ ((tstringdef(resultdef).stringtype in [st_widestring,st_unicodestring]) or
(torddef(left.resultdef).ordtype=uchar) or
{ >=128 is destroyed }
(tordconstnode(left).value.uvalue<128)) then
begin
- if tstringdef(resultdef).stringtype=st_widestring then
+ if tstringdef(resultdef).stringtype in [st_widestring,st_unicodestring] then
begin
initwidestring(ws);
if torddef(left.resultdef).ordtype=uwidechar then
@@ -953,7 +953,7 @@ implementation
if torddef(left.resultdef).ordtype<>uwidechar then
procname := 'fpc_char_to_'
else
- procname := 'fpc_wchar_to_';
+ procname := 'fpc_uchar_to_';
procname:=procname+tstringdef(resultdef).stringtypname;
{ and the parameter }
@@ -1193,7 +1193,8 @@ implementation
inserttypeconv(left,cwidestringtype)
else
if is_pchar(resultdef) and
- is_widestring(left.resultdef) then
+ (is_widestring(left.resultdef) or
+ is_unicodestring(left.resultdef)) then
begin
inserttypeconv(left,cansistringtype);
{ the second pass of second_cstring_to_pchar expects a }
@@ -2037,8 +2038,8 @@ implementation
if (convtype=tc_string_2_string) and
(
((not is_widechararray(left.resultdef) and
- not is_widestring(left.resultdef)) or
- (tstringdef(resultdef).stringtype=st_widestring) or
+ not is_wide_or_unicode_string(left.resultdef)) or
+ (tstringdef(resultdef).stringtype in [st_widestring,st_unicodestring]) or
{ non-ascii chars would be replaced with '?' -> loses info }
not hasnonasciichars(pcompilerwidestring(tstringconstnode(left).value_str)))
) then
@@ -2530,10 +2531,10 @@ implementation
begin
if (torddef(resultdef).ordtype=uchar) and
(torddef(left.resultdef).ordtype=uwidechar) then
- fname := 'fpc_wchar_to_char'
+ fname := 'fpc_uchar_to_char'
else if (torddef(resultdef).ordtype=uwidechar) and
(torddef(left.resultdef).ordtype=uchar) then
- fname := 'fpc_char_to_wchar'
+ fname := 'fpc_char_to_uchar'
else
internalerror(2007081201);
diff --git a/compiler/ncon.pas b/compiler/ncon.pas
index 3adab063cd..e08aa5b20b 100644
--- a/compiler/ncon.pas
+++ b/compiler/ncon.pas
@@ -866,7 +866,8 @@ implementation
resultdef:=cshortstringtype;
cst_ansistring :
resultdef:=cansistringtype;
- cst_unicodestring,
+ cst_unicodestring :
+ resultdef:=cunicodestringtype;
cst_widestring :
resultdef:=cwidestringtype;
cst_longstring :
@@ -877,11 +878,15 @@ implementation
function tstringconstnode.pass_1 : tnode;
begin
result:=nil;
- if (cst_type in [cst_ansistring,cst_widestring,cst_unicodestring]) and
- (len=0) then
- expectloc:=LOC_CONSTANT
+ if (cst_type in [cst_ansistring,cst_widestring,cst_unicodestring]) then
+ begin
+ if len=0 then
+ expectloc:=LOC_CONSTANT
+ else
+ expectloc:=LOC_REGISTER
+ end
else
- expectloc:=LOC_CREFERENCE;
+ expectloc:=LOC_CREFERENCE;
end;
@@ -920,8 +925,8 @@ implementation
if def.typ<>stringdef then
internalerror(200510011);
{ convert ascii 2 unicode }
- if (tstringdef(def).stringtype=st_widestring) and
- (cst_type<>cst_widestring) then
+ if (tstringdef(def).stringtype in [st_widestring,st_unicodestring]) and
+ not(cst_type in [cst_widestring,cst_unicodestring]) then
begin
initwidestring(pw);
ascii2unicode(value_str,len,pw);
@@ -930,8 +935,8 @@ implementation
end
else
{ convert unicode 2 ascii }
- if (cst_type=cst_widestring) and
- (tstringdef(def).stringtype<>st_widestring) then
+ if (cst_type in [cst_widestring,cst_unicodestring]) and
+ not(tstringdef(def).stringtype in [st_widestring,st_unicodestring]) then
begin
pw:=pcompilerwidestring(value_str);
getmem(pc,getlengthwidestring(pw)+1);
diff --git a/compiler/ninl.pas b/compiler/ninl.pas
index 7d1ac96510..fcfbc21dde 100644
--- a/compiler/ninl.pas
+++ b/compiler/ninl.pas
@@ -1676,7 +1676,7 @@ implementation
result:=cordconstnode.create(0,u8inttype,false);
end
else if not is_ansistring(left.resultdef) and
- not is_widestring(left.resultdef) then
+ not is_wide_or_unicode_string(left.resultdef) then
result:=cordconstnode.create(tstringdef(left.resultdef).len,u8inttype,true)
end;
end;
@@ -2040,8 +2040,8 @@ implementation
{ length) }
if (left.nodetype=typeconvn) and
(ttypeconvnode(left).left.resultdef.typ=stringdef) and
- not(is_widestring(left.resultdef) xor
- is_widestring(ttypeconvnode(left).left.resultdef)) then
+ not(is_wide_or_unicode_string(left.resultdef) xor
+ is_wide_or_unicode_string(ttypeconvnode(left).left.resultdef)) then
begin
hp:=ttypeconvnode(left).left;
ttypeconvnode(left).left:=nil;
@@ -2334,7 +2334,7 @@ implementation
result:=load_high_value_node(tparavarsym(tloadnode(left).symtableentry))
end
else if is_ansistring(left.resultdef) or
- is_widestring(left.resultdef) then
+ is_wide_or_unicode_string(left.resultdef) then
CGMessage(type_e_mismatch)
end;
end;
diff --git a/compiler/nmem.pas b/compiler/nmem.pas
index 8adb48a128..9790c14a5d 100644
--- a/compiler/nmem.pas
+++ b/compiler/nmem.pas
@@ -667,7 +667,7 @@ implementation
ansi/widestring needs to be valid }
valid:=is_dynamic_array(left.resultdef) or
is_ansistring(left.resultdef) or
- is_widestring(left.resultdef) or
+ is_wide_or_unicode_string(left.resultdef) or
{ implicit pointer dereference -> pointer is read }
(left.resultdef.typ = pointerdef);
if valid then
@@ -827,7 +827,8 @@ implementation
if (nf_callunique in flags) and
(is_ansistring(left.resultdef) or
- (is_widestring(left.resultdef) and not(tf_winlikewidestring in target_info.flags))) then
+ is_unicodestring(left.resultdef) or
+ (is_widestring(left.resultdef) and not(tf_winlikewidestring in target_info.flags))) then
begin
left := ctypeconvnode.create_internal(ccallnode.createintern('fpc_'+tstringdef(left.resultdef).stringtypname+'_unique',
ccallparanode.create(
diff --git a/compiler/nutils.pas b/compiler/nutils.pas
index 09b033a1a3..1fc9444d3b 100644
--- a/compiler/nutils.pas
+++ b/compiler/nutils.pas
@@ -531,7 +531,7 @@ implementation
if not assigned(p.resultdef) then
typecheckpass(p);
if is_ansistring(p.resultdef) or
- is_widestring(p.resultdef) or
+ is_wide_or_unicode_string(p.resultdef) or
is_interfacecom(p.resultdef) or
is_dynamic_array(p.resultdef) then
begin
@@ -584,6 +584,18 @@ implementation
cnilnode.create
));
end
+ else if is_unicodestring(p.resultdef) then
+ begin
+ result:=internalstatements(newstatement);
+ addstatement(newstatement,ccallnode.createintern('fpc_unicodestr_decr_ref',
+ ccallparanode.create(
+ ctypeconvnode.create_internal(p,voidpointertype),
+ nil)));
+ addstatement(newstatement,cassignmentnode.create(
+ ctypeconvnode.create_internal(p.getcopy,voidpointertype),
+ cnilnode.create
+ ));
+ end
else if is_interfacecom(p.resultdef) then
begin
result:=internalstatements(newstatement);
diff --git a/compiler/options.pas b/compiler/options.pas
index 73771c8ba0..ae804c51cb 100644
--- a/compiler/options.pas
+++ b/compiler/options.pas
@@ -71,7 +71,7 @@ implementation
uses
widestr,
- charset,
+ {$ifdef VER2_2}ccharset{$else VER2_2}charset{$endif VER2_2},
SysUtils,
version,
cutils,cmsgs,
@@ -2580,6 +2580,9 @@ begin
set_system_macro('FPC_PATCH',patch_nr);
set_system_macro('FPC_FULLVERSION',Format('%d%.02d%.02d',[StrToInt(version_nr),StrToInt(release_nr),StrToInt(patch_nr)]));
+ if not(target_info.system in system_windows) then
+ def_system_macro('FPC_WIDESTRING_EQUAL_UNICODESTRING');
+
for i:=low(tfeature) to high(tfeature) do
if i in features then
def_system_macro('FPC_HAS_FEATURE_'+featurestr[i]);
diff --git a/compiler/pdecl.pas b/compiler/pdecl.pas
index 7f6404b344..3dadd92479 100644
--- a/compiler/pdecl.pas
+++ b/compiler/pdecl.pas
@@ -96,7 +96,7 @@ implementation
end;
stringconstn:
begin
- if is_widestring(p.resultdef) then
+ if is_wide_or_unicode_string(p.resultdef) then
begin
initwidestring(pw);
copywidestring(pcompilerwidestring(tstringconstnode(p).value_str),pw);
diff --git a/compiler/pinline.pas b/compiler/pinline.pas
index f91c02bc05..857184d752 100644
--- a/compiler/pinline.pas
+++ b/compiler/pinline.pas
@@ -720,6 +720,9 @@ implementation
is_widechararray(paradef) or
is_pwidechar(paradef) then
copynode:=ccallnode.createintern('fpc_widestr_copy',paras)
+ else
+ if is_unicodestring(paradef) then
+ copynode:=ccallnode.createintern('fpc_unicodestr_copy',paras)
else
if is_char(paradef) then
copynode:=ccallnode.createintern('fpc_char_copy',paras)
diff --git a/compiler/ppu.pas b/compiler/ppu.pas
index 0c9f6c320f..51b11ae05d 100644
--- a/compiler/ppu.pas
+++ b/compiler/ppu.pas
@@ -43,7 +43,7 @@ type
{$endif Test_Double_checksum}
const
- CurrentPPUVersion = 91;
+ CurrentPPUVersion = 92;
{ buffer sizes }
maxentrysize = 1024;
diff --git a/compiler/psystem.pas b/compiler/psystem.pas
index 8cb3d53427..b7f1f9b271 100644
--- a/compiler/psystem.pas
+++ b/compiler/psystem.pas
@@ -157,7 +157,10 @@ implementation
{ should we give a length to the default long and ansi string definition ?? }
clongstringtype:=tstringdef.createlong(-1);
cansistringtype:=tstringdef.createansi;
- cwidestringtype:=tstringdef.createwide;
+ if target_info.system in system_windows then
+ cwidestringtype:=tstringdef.createwide
+ else
+ cwidestringtype:=tstringdef.createunicode;
cunicodestringtype:=tstringdef.createunicode;
{ length=0 for shortstring is open string (needed for readln(string) }
openshortstringtype:=tstringdef.createshort(0);
@@ -265,6 +268,7 @@ implementation
addtype('AnsiString',cansistringtype);
addtype('WideString',cwidestringtype);
addtype('UnicodeString',cunicodestringtype);
+
addtype('OpenString',openshortstringtype);
addtype('Boolean',booltype);
addtype('ByteBool',bool8type);
diff --git a/compiler/ptconst.pas b/compiler/ptconst.pas
index 4f9aa821f8..2106c5c0a2 100644
--- a/compiler/ptconst.pas
+++ b/compiler/ptconst.pas
@@ -431,7 +431,7 @@ implementation
{ convert to widestring stringconstn }
inserttypeconv(p,cwidestringtype);
if (p.nodetype=stringconstn) and
- (tstringconstnode(p).cst_type=cst_widestring) then
+ (tstringconstnode(p).cst_type in [cst_widestring,cst_unicodestring]) then
begin
pw:=pcompilerwidestring(tstringconstnode(p).value_str);
for i:=0 to tstringconstnode(p).len-1 do
@@ -641,7 +641,7 @@ implementation
begin
n:=comp_expr(true);
{ load strval and strlength of the constant tree }
- if (n.nodetype=stringconstn) or is_widestring(def) or is_constwidecharnode(n) then
+ if (n.nodetype=stringconstn) or is_wide_or_unicode_string(def) or is_constwidecharnode(n) then
begin
{ convert to the expected string type so that
for widestrings strval is a pcompilerwidestring }
diff --git a/compiler/scanner.pas b/compiler/scanner.pas
index 196e9efa8e..1285a448ed 100644
--- a/compiler/scanner.pas
+++ b/compiler/scanner.pas
@@ -962,7 +962,7 @@ In case not, the value returned can be arbitrary.
else
l:=tarraydef(hdef).highrange;
stringdef:
- if is_open_string(hdef) or is_ansistring(hdef) or is_widestring(hdef) then
+ if is_open_string(hdef) or is_ansistring(hdef) or is_wide_or_unicode_string(hdef) then
Message(type_e_mismatch)
else
l:=tstringdef(hdef).len;
diff --git a/compiler/symconst.pas b/compiler/symconst.pas
index 5b1dca5cbb..12c1a911df 100644
--- a/compiler/symconst.pas
+++ b/compiler/symconst.pas
@@ -61,6 +61,8 @@ const
tkDynArray = 21;
tkInterfaceCorba = 22;
tkProcVar = 23;
+ tkUString = 24;
+ tkUChar = 25;
otSByte = 0;
otUByte = 1;
@@ -446,7 +448,7 @@ type
tvariantequaltype = (
tve_incompatible,
tve_chari64,
- tve_unicodestring,
+ tve_ustring,
tve_wstring,
tve_astring,
tve_sstring,
diff --git a/compiler/widestr.pas b/compiler/widestr.pas
index 1c0c0d634d..4747e655b6 100644
--- a/compiler/widestr.pas
+++ b/compiler/widestr.pas
@@ -28,8 +28,7 @@ unit widestr;
interface
uses
- charset,globtype
- ;
+ {$ifdef VER2_2}ccharset{$else VER2_2}charset{$endif VER2_2},globtype;
type
diff --git a/packages/iconvenc/src/iconvenc.pas b/packages/iconvenc/src/iconvenc.pas
index c955398de5..11c144c85e 100755
--- a/packages/iconvenc/src/iconvenc.pas
+++ b/packages/iconvenc/src/iconvenc.pas
@@ -2,7 +2,7 @@
This file is part of the Free Pascal run time library.
Copyright (c) 2000 by Marco van de Voort(marco@freepascal.org)
member of the Free Pascal development team
-
+
libiconv header translation + a helper routine
http://wiki.freepascal.org/iconvenc
@@ -15,7 +15,8 @@
}
unit iconvenc;
-interface
+
+interface
{$mode objfpc}{$H+}
{DEFINE LOADDYNAMIC}
@@ -23,144 +24,150 @@ interface
uses
baseunix,
{$ifdef LOADDYNAMIC}
- dl,
+ dl,
{$endif}
initc;
const
- n=1;
+ n = 1;
+
type
- Piconv_t = ^iconv_t;
+ piconv_t = ^iconv_t;
iconv_t = pointer;
-
- Ticonv_open = function (__tocode:Pchar; __fromcode:Pchar):iconv_t;cdecl;
- Ticonv = function (__cd:iconv_t; __inbuf:PPchar; __inbytesleft:Psize_t; __outbuf:PPchar; __outbytesleft:Psize_t):size_t;cdecl;
- Ticonv_close = function (__cd:iconv_t):longint;cdecl;
+
+ Ticonv_open = function(__tocode: pchar; __fromcode: pchar): iconv_t; cdecl;
+ Ticonv = function(__cd: iconv_t; __inbuf: ppchar; __inbytesleft: psize_t; __outbuf: ppchar; __outbytesleft: psize_t): size_t; cdecl;
+ Ticonv_close = function(__cd: iconv_t): cint; cdecl;
{$IFNDEF LOADDYNAMIC}
{$ifndef Linux} // and other OSes with iconv in libc.
{$linklib iconv}
{$endif}
-function iconv_open (__tocode:Pchar; __fromcode:Pchar):iconv_t;cdecl; external;
-function iconv (__cd:iconv_t; __inbuf:PPchar; __inbytesleft:Psize_t; __outbuf:PPchar; __outbytesleft:Psize_t):size_t;cdecl; external;
-function iconv_close (__cd:iconv_t):longint;cdecl; external;
+function iconv_open(__tocode: pchar; __fromcode: pchar): iconv_t; cdecl; external;
+function iconv (__cd: iconv_t; __inbuf: ppchar; __inbytesleft: psize_t; __outbuf: ppchar; __outbytesleft: psize_t): size_t; cdecl; external;
+function iconv_close (__cd: iconv_t): cint; cdecl; external;
-var
- IconvLibFound: Boolean = False;
+var
+ IconvLibFound: boolean = False;
{$ELSE}
var
- iconv_lib: Pointer;
+ iconv_lib: pointer;
iconv_open: Ticonv_open;
iconv: Ticonv;
iconv_close: Ticonv_close;
- IconvLibFound: Boolean = True;
-function TryLoadLib(LibName:String;var error:string):Boolean; // can be used to load non standard libname
+ IconvLibFound: boolean = true;
+
+function TryLoadLib(LibName: string; var error: string): boolean; // can be used to load non standard libname
{$endif}
-function Iconvert(S:string;var res:string; FromEncoding, ToEncoding: string): cint;
-function InitIconv (Var error:string): Boolean;
+function Iconvert(s: string; var res: string; FromEncoding, ToEncoding: string): cint;
+function InitIconv(var error: string): boolean;
implementation
{$IFDEF LOADDYNAMIC}
-function TryLoadLib(LibName:String;var error:string):Boolean;
-function resolvesymbol (var funcptr; symbol:string):boolean;
+function TryLoadLib(LibName: string; var error: string): boolean;
+ function resolvesymbol (var funcptr; symbol: string): Boolean;
+ begin
+ pointer(funcptr) := pointer(dlsym(iconv_lib, pchar(symbol)));
+ result := assigned(pointer(funcptr));
+ if not result then
+ error := error+#13#10+dlerror();
+ end;
+
+var
+ res: boolean;
begin
- pointer(funcptr):=pointer(dlsym(iconv_lib, pchar(symbol)));
- result:=assigned(pointer(funcptr));
- if not result then
- error:=error+#13#10+dlerror();
-end;
-
-var res:boolean;
-
-begin
- result:=false;
- Error:=Error+#13#10'Trying '+LibName;
- iconv_lib:=dlopen(pchar(libname), RTLD_NOW);
+ result := false;
+ Error := Error+#13#10'Trying '+LibName;
+ iconv_lib := dlopen(pchar(libname), RTLD_NOW);
if Assigned(iconv_lib) then
begin
- result:=true;
- result := result and resolvesymbol(pointer(iconv),'iconv');
- result := result and resolvesymbol(pointer(iconv_open),'iconv_open');
- result := result and resolvesymbol(pointer(iconv_close),'iconv_close');
+ result := true;
+ result := result and resolvesymbol(pointer(iconv),'iconv');
+ result := result and resolvesymbol(pointer(iconv_open),'iconv_open');
+ result := result and resolvesymbol(pointer(iconv_close),'iconv_close');
// if not res then
// dlclose(iconv_lib);
- end
- else
- error:=error+#13#10+dlerror();
+ end else
+ error:=error+#13#10+dlerror();
end;
{$ENDIF}
-function InitIconv(Var error:string): Boolean;
+function InitIconv(var error: string): boolean;
begin
- result:=true;
+ result := true;
{$ifdef LOADDYNAMIC}
- error:='';
- if not TryLoadLib('libc.so.6',error) then
- if not TryLoadLib('libiconv.so',error) then
- result:=false;
+ error := '';
+ if not TryLoadLib('libc.so.6', error) then
+ if not TryLoadLib('libiconv.so', error) then
+ result := false;
{$endif}
- iconvlibfound:=iconvlibfound or result;
+ iconvlibfound := iconvlibfound or result;
end;
-function Iconvert(S:string;var res:string; FromEncoding, ToEncoding: string): cint;
+function Iconvert(S: string; var Res: string; FromEncoding, ToEncoding: string): cint;
var
InLen, OutLen, Offset: size_t;
- Src, Dst: PChar;
+ Src, Dst: pchar;
H: iconv_t;
lerr: cint;
- iconvres : cint;
+ iconvres: size_t;
begin
- H:=iconv_open(PChar(ToEncoding), PChar(FromEncoding));
+ H := iconv_open(PChar(ToEncoding), PChar(FromEncoding));
if not assigned(H) then
- begin
- Res:=S;
- Exit(-1);
+ begin
+ Res := S;
+ exit(-1);
end;
+
try
SetLength(Res, Length(S));
- InLen:=Length(S);
- OutLen:=Length(Res);
- Src:=PChar(S);
- Dst:=PChar(Res);
- while InLen>0 do
+ InLen := Length(S);
+ OutLen := Length(Res);
+ Src := PChar(S);
+ Dst := PChar(Res);
+
+ while InLen > 0 do
begin
- iconvres:= iconv(H, @Src, @InLen, @Dst, @OutLen);
- if iconvres=Cint(-1) then
+ iconvres := iconv(H, @Src, @InLen, @Dst, @OutLen);
+ if iconvres = size_t(-1) then
begin
- lerr:=cerrno;
- if lerr=ESysEILSEQ then // unknown char, skip
- begin
- Dst^:=Src^;
- Inc(Src);
- Inc(Dst);
- Dec(InLen);
- Dec(OutLen);
- end
- else
- if lerr=ESysE2BIG then
+ lerr := cerrno;
+ if lerr = ESysEILSEQ then // unknown char, skip
+ begin
+ Dst^ := Src^;
+ Inc(Src);
+ Inc(Dst);
+ Dec(InLen);
+ Dec(OutLen);
+ end
+ else
+ if lerr = ESysE2BIG then
begin
- Offset:=Dst-PChar(Res);
+ Offset := Dst - PChar(Res);
SetLength(Res, Length(Res)+InLen*2+5); // 5 is minimally one utf-8 char
- Dst:=PChar(Res)+Offset;
- OutLen:=Length(Res)-Offset;
+ Dst := PChar(Res) + Offset;
+ OutLen := Length(Res) - Offset;
end
else
exit(-1)
end;
end;
+
// iconv has a buffer that needs flushing, specially if the last char is not #0
- iconvres:=iconv(H, nil, nil, @Dst, @Outlen);
-
- SetLength(Res, Length(Res)-outlen);
+ iconv(H, nil, nil, @Dst, @Outlen);
+
+ // trim output buffer
+ SetLength(Res, Length(Res) - Outlen);
finally
iconv_close(H);
- end;
- result:=0;
+ end;
+
+ Result := 0;
end;
end.
diff --git a/rtl/inc/compproc.inc b/rtl/inc/compproc.inc
index 37ae529f33..b4f6b7d9fb 100644
--- a/rtl/inc/compproc.inc
+++ b/rtl/inc/compproc.inc
@@ -123,9 +123,16 @@ procedure fpc_AnsiStr_Currency(c : currency;len,fr : SizeInt;out s : ansistring)
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
-procedure fpc_WideStr_sint(v : valsint; Len : SizeInt; out S : WideString); compilerproc;
-procedure fpc_WideStr_uint(v : valuint;Len : SizeInt; out S : WideString); compilerproc;
+ {$if not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
+ procedure fpc_WideStr_sint(v : valsint; Len : SizeInt; out S : WideString); compilerproc;
+ procedure fpc_WideStr_uint(v : valuint;Len : SizeInt; out S : WideString); compilerproc;
+ {$endif not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
+ {$ifndef VER2_2}
+ procedure fpc_UnicodeStr_sint(v : valsint; Len : SizeInt; out S : UnicodeString); compilerproc;
+ procedure fpc_UnicodeStr_uint(v : valuint;Len : SizeInt; out S : UnicodeString); compilerproc;
+ {$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
+
{$ifndef CPU64}
procedure fpc_shortstr_qword(v : qword;len : SizeInt;out s : shortstring); compilerproc;
procedure fpc_shortstr_int64(v : int64;len : SizeInt;out s : shortstring); compilerproc;
@@ -137,17 +144,33 @@ procedure fpc_WideStr_uint(v : valuint;Len : SizeInt; out S : WideString); compi
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
- procedure fpc_widestr_qword(v : qword;len : SizeInt;out s : widestring); compilerproc;
- procedure fpc_widestr_int64(v : int64;len : SizeInt;out s : widestring); compilerproc;
+ {$if not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
+ procedure fpc_widestr_qword(v : qword;len : SizeInt;out s : widestring); compilerproc;
+ procedure fpc_widestr_int64(v : int64;len : SizeInt;out s : widestring); compilerproc;
+ {$endif not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
+ {$ifndef VER2_2}
+ procedure fpc_UnicodeStr_qword(v : qword;len : SizeInt;out s : UnicodeString); compilerproc;
+ procedure fpc_UnicodeStr_int64(v : int64;len : SizeInt;out s : UnicodeString); compilerproc;
+ {$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$endif CPU64}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
-{$ifndef FPUNONE}
-procedure fpc_WideStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : WideString); compilerproc;
-{$endif}
-{$ifdef FPC_HAS_STR_CURRENCY}
-procedure fpc_WideStr_Currency(c : Currency;len,fr : SizeInt;out s : WideString);compilerproc;
-{$endif FPC_HAS_STR_CURRENCY}
+ {$if not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
+ {$ifndef FPUNONE}
+ procedure fpc_WideStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : WideString); compilerproc;
+ {$endif}
+ {$ifdef FPC_HAS_STR_CURRENCY}
+ procedure fpc_WideStr_Currency(c : Currency;len,fr : SizeInt;out s : WideString);compilerproc;
+ {$endif FPC_HAS_STR_CURRENCY}
+ {$endif not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
+ {$ifndef VER2_2}
+ {$ifndef FPUNONE}
+ procedure fpc_UnicodeStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : UnicodeString); compilerproc;
+ {$endif}
+ {$ifdef FPC_HAS_STR_CURRENCY}
+ procedure fpc_UnicodeStr_Currency(c : Currency;len,fr : SizeInt;out s : UnicodeString);compilerproc;
+ {$endif FPC_HAS_STR_CURRENCY}
+ {$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef FPUNONE}
@@ -174,15 +197,28 @@ Function fpc_Val_SInt_AnsiStr (DestSize: SizeInt; Const S : AnsiString; out Code
Function fpc_Val_Currency_AnsiStr(Const S : AnsiString; out Code : ValSInt): Currency; compilerproc;
function fpc_Val_enum_ansistr(str2ordindex:pointer;const s:ansistring;out code:valsint):longint; compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
+
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
-{$ifndef FPUNONE}
-Function fpc_Val_Real_WideStr(Const S : WideString; out Code : ValSInt): ValReal; compilerproc;
-{$endif}
-Function fpc_Val_SInt_WideStr (DestSize: SizeInt; Const S : WideString; out Code : ValSInt): ValSInt; compilerproc;
-Function fpc_Val_UInt_WideStr (Const S : WideString; out Code : ValSInt): ValUInt; compilerproc;
-function fpc_val_enum_widestr(str2ordindex:pointer;const s:widestring;out code:valsint):longint;compilerproc;
-Function fpc_Val_Currency_WideStr(Const S : WideString; out Code : ValSInt): Currency; compilerproc;
+ {$if not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
+ {$ifndef FPUNONE}
+ Function fpc_Val_Real_WideStr(Const S : WideString; out Code : ValSInt): ValReal; compilerproc;
+ {$endif}
+ Function fpc_Val_SInt_WideStr (DestSize: SizeInt; Const S : WideString; out Code : ValSInt): ValSInt; compilerproc;
+ Function fpc_Val_UInt_WideStr (Const S : WideString; out Code : ValSInt): ValUInt; compilerproc;
+ function fpc_val_Enum_WideStr (str2ordindex:pointer;const s:WideString;out code:valsint):longint;compilerproc;
+ Function fpc_Val_Currency_WideStr(Const S : WideString; out Code : ValSInt): Currency; compilerproc;
+ {$endif not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
+ {$ifndef VER2_2}
+ {$ifndef FPUNONE}
+ Function fpc_Val_Real_UnicodeStr(Const S : UnicodeString; out Code : ValSInt): ValReal; compilerproc;
+ {$endif}
+ Function fpc_Val_SInt_UnicodeStr (DestSize: SizeInt; Const S : UnicodeString; out Code : ValSInt): ValSInt; compilerproc;
+ Function fpc_Val_UInt_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): ValUInt; compilerproc;
+ function fpc_val_Enum_UnicodeStr(str2ordindex:pointer;const s:UnicodeString;out code:valsint):longint;compilerproc;
+ Function fpc_Val_Currency_UnicodeStr(Const S : UnicodeString; out Code : ValSInt): Currency; compilerproc;
+ {$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
+
{$ifndef CPU64}
Function fpc_val_int64_shortstr(Const S: ShortString; out Code: ValSInt): Int64; compilerproc;
Function fpc_val_qword_shortstr(Const S: ShortString; out Code: ValSInt): QWord; compilerproc;
@@ -190,10 +226,18 @@ Function fpc_val_qword_shortstr(Const S: ShortString; out Code: ValSInt): QWord;
Function fpc_Val_qword_AnsiStr (Const S : AnsiString; out Code : ValSInt): qword;compilerproc;
Function fpc_Val_int64_AnsiStr (Const S : AnsiString; out Code : ValSInt): Int64; compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
+
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
+{$if not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
Function fpc_Val_qword_WideStr (Const S : WideString; out Code : ValSInt): qword; compilerproc;
Function fpc_Val_int64_WideStr (Const S : WideString; out Code : ValSInt): Int64; compilerproc;
+{$endif not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
+{$ifndef VER2_2}
+Function fpc_Val_qword_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): qword; compilerproc;
+Function fpc_Val_int64_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): Int64; compilerproc;
+{$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
+
{$endif CPU64}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
@@ -243,6 +287,11 @@ Function fpc_AnsiStr_ShortStr_Compare (Var S1 : Pointer; Var S2 : ShortString):
Function fpc_ansistr_Unique(Var S : Pointer): Pointer; compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
+{*****************************************************************************
+ Widestring support
+*****************************************************************************}
+
+{$if not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure fpc_WideStr_Decr_Ref (Var S : Pointer); compilerproc;
Procedure fpc_WideStr_Incr_Ref (Var S : Pointer); compilerproc;
@@ -267,22 +316,11 @@ Function fpc_PChar_To_WideStr(const p : pchar): WideString; compilerproc;
Function fpc_CharArray_To_WideStr(const arr: array of char; zerobased: boolean = true): WideString; compilerproc;
{$ifndef FPC_STRTOCHARARRAYPROC}
function fpc_widestr_to_chararray(arraysize: SizeInt; const src: WideString): fpc_big_chararray; compilerproc;
-Function fpc_shortstr_to_widechararray(arraysize: SizeInt; const src: ShortString): fpc_big_widechararray; compilerproc;
-Function fpc_ansistr_to_widechararray(arraysize: SizeInt; const src: AnsiString): fpc_big_widechararray; compilerproc;
Function fpc_widestr_to_widechararray(arraysize: SizeInt; const src: WideString): fpc_big_widechararray; compilerproc;
{$else ndef FPC_STRTOCHARARRAYPROC}
procedure fpc_widestr_to_chararray(out res: array of char; const src: WideString); compilerproc;
-procedure fpc_shortstr_to_widechararray(out res: array of widechar; const src: ShortString); compilerproc;
-procedure fpc_ansistr_to_widechararray(out res: array of widechar; const src: AnsiString); compilerproc;
procedure fpc_widestr_to_widechararray(out res: array of widechar; const src: WideString); compilerproc;
{$endif ndef FPC_STRTOCHARARRAYPROC}
-{$ifndef FPC_STRTOSHORTSTRINGPROC}
-Function fpc_WideCharArray_To_ShortStr(const arr: array of widechar; zerobased: boolean = true): shortstring; compilerproc;
-{$else FPC_STRTOSHORTSTRINGPROC}
-procedure fpc_WideCharArray_To_ShortStr(out res : shortstring;const arr: array of widechar; zerobased: boolean = true); compilerproc;
-{$endif FPC_STRTOSHORTSTRINGPROC}
-Function fpc_WideCharArray_To_AnsiStr(const arr: array of widechar; zerobased: boolean = true): AnsiString; compilerproc;
-Function fpc_WideCharArray_To_WideStr(const arr: array of widechar; zerobased: boolean = true): WideString; compilerproc;
Function fpc_WideStr_Compare(const S1,S2 : WideString): SizeInt; compilerproc;
Function fpc_WideStr_Compare_equal(const S1,S2 : WideString): SizeInt; compilerproc;
Procedure fpc_WideStr_CheckZero(p : pointer); compilerproc;
@@ -292,28 +330,131 @@ Function fpc_widestr_Copy (Const S : WideString; Index,Size : SizeInt) : WideSt
{$ifndef FPC_WINLIKEWIDESTRING}
function fpc_widestr_Unique(Var S : Pointer): Pointer; compilerproc;
{$endif FPC_WINLIKEWIDESTRING}
-Function fpc_Char_To_WChar(const c : Char): WideChar; compilerproc;
-Function fpc_WChar_To_Char(const c : WideChar): Char; compilerproc;
+Function fpc_WChar_To_AnsiStr(const c : WideChar): AnsiString; compilerproc;
+Function fpc_WChar_To_WideStr(const c : WideChar): WideString; compilerproc;
+{$ifndef VER2_2}
+Function fpc_UChar_To_WideStr(const c : WideChar): WideString; compilerproc;
+{$endif VER2_2}
+{$endif FPC_HAS_FEATURE_WIDESTRINGS}
+
+{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
+Function fpc_PWideChar_To_WideStr(const p : pwidechar): widestring; compilerproc;
+{$endif FPC_HAS_FEATURE_WIDESTRINGS}
+{$endif defined(WINDOWS) or defined(VER2_2)}
+
+{*****************************************************************************
+ Unicode string support
+*****************************************************************************}
+
+{$ifndef VER2_2}
+{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
+Procedure fpc_UnicodeStr_Decr_Ref (Var S : Pointer); compilerproc;
+Procedure fpc_UnicodeStr_Incr_Ref (S : Pointer); compilerproc;
+{$ifndef FPC_STRTOSHORTSTRINGPROC}
+function fpc_UnicodeStr_To_ShortStr (high_of_res: SizeInt;const S2 : UnicodeString): shortstring; compilerproc;
+{$else FPC_STRTOSHORTSTRINGPROC}
+procedure fpc_UnicodeStr_To_ShortStr (out res: ShortString;const S2 : UnicodeString); compilerproc;
+{$endif FPC_STRTOSHORTSTRINGPROC}
+Function fpc_ShortStr_To_UnicodeStr (Const S2 : ShortString): UnicodeString; compilerproc;
+Function fpc_UnicodeStr_To_AnsiStr (const S2 : UnicodeString): AnsiString; compilerproc;
+Function fpc_AnsiStr_To_UnicodeStr (Const S2 : AnsiString): UnicodeString; compilerproc;
+Function fpc_UnicodeStr_To_WideStr (const S2 : UnicodeString): WideString; compilerproc;
+Function fpc_WideStr_To_UnicodeStr (Const S2 : WideString): UnicodeString; compilerproc;
+Procedure fpc_UnicodeStr_Assign (Var S1 : Pointer;S2 : Pointer); compilerproc;
+{$ifndef STR_CONCAT_PROCS}
+Function fpc_UnicodeStr_Concat (const S1,S2 : UnicodeString) : UnicodeString; compilerproc;
+function fpc_UnicodeStr_Concat_multi (const sarr:array of Unicodestring): unicodestring; compilerproc;
+{$else STR_CONCAT_PROCS}
+Procedure fpc_UnicodeStr_Concat (Var DestS : Unicodestring;const S1,S2 : UnicodeString); compilerproc;
+Procedure fpc_UnicodeStr_Concat_multi (Var DestS : Unicodestring;const sarr:array of Unicodestring); compilerproc;
+{$endif STR_CONCAT_PROCS}
+Function fpc_Char_To_UnicodeStr(const c : Char): UnicodeString; compilerproc;
+Function fpc_PChar_To_UnicodeStr(const p : pchar): UnicodeString; compilerproc;
+Function fpc_CharArray_To_UnicodeStr(const arr: array of char; zerobased: boolean = true): UnicodeString; compilerproc;
+{$ifndef FPC_STRTOCHARARRAYPROC}
+function fpc_unicodestr_to_chararray(arraysize: SizeInt; const src: UnicodeString): fpc_big_chararray; compilerproc;
+Function fpc_shortstr_to_unicodechararray(arraysize: SizeInt; const src: ShortString): fpc_big_unicodechararray; compilerproc;
+Function fpc_ansistr_to_unicodechararray(arraysize: SizeInt; const src: AnsiString): fpc_big_unicodechararray; compilerproc;
+Function fpc_unicodestr_to_unicodechararray(arraysize: SizeInt; const src: UnicodeString): fpc_big_unicodechararray; compilerproc;
+{$else ndef FPC_STRTOCHARARRAYPROC}
+procedure fpc_unicodestr_to_chararray(out res: array of char; const src: UnicodeString); compilerproc;
+procedure fpc_shortstr_to_unicodechararray(out res: array of unicodechar; const src: ShortString); compilerproc;
+procedure fpc_ansistr_to_unicodechararray(out res: array of unicodechar; const src: AnsiString); compilerproc;
+procedure fpc_unicodestr_to_unicodechararray(out res: array of unicodechar; const src: UnicodeString); compilerproc;
+{$endif ndef FPC_STRTOCHARARRAYPROC}
+{$ifndef FPC_STRTOSHORTSTRINGPROC}
+Function fpc_UnicodeCharArray_To_ShortStr(const arr: array of unicodechar; zerobased: boolean = true): shortstring; compilerproc;
+{$else FPC_STRTOSHORTSTRINGPROC}
+procedure fpc_UnicodeCharArray_To_ShortStr(out res : shortstring;const arr: array of unicodechar; zerobased: boolean = true); compilerproc;
+{$endif FPC_STRTOSHORTSTRINGPROC}
+Function fpc_UnicodeCharArray_To_AnsiStr(const arr: array of unicodechar; zerobased: boolean = true): AnsiString; compilerproc;
+Function fpc_UnicodeCharArray_To_UnicodeStr(const arr: array of unicodechar; zerobased: boolean = true): UnicodeString; compilerproc;
+{$ifndef VER2_2}
+{$ifndef FPC_STRTOSHORTSTRINGPROC}
+Function fpc_WideCharArray_To_ShortStr(const arr: array of widechar; zerobased: boolean = true): shortstring; compilerproc;
+{$else FPC_STRTOSHORTSTRINGPROC}
+procedure fpc_WideCharArray_To_ShortStr(out res : shortstring;const arr: array of widechar; zerobased: boolean = true); compilerproc;
+{$endif FPC_STRTOSHORTSTRINGPROC}
+Function fpc_WideCharArray_To_AnsiStr(const arr: array of widechar; zerobased: boolean = true): AnsiString; compilerproc;
+Function fpc_WideCharArray_To_WideStr(const arr: array of widechar; zerobased: boolean = true): WideString; compilerproc;
+Function fpc_WideCharArray_To_UnicodeStr(const arr: array of widechar; zerobased: boolean = true): UnicodeString; compilerproc;
+{$ifndef FPC_STRTOCHARARRAYPROC}
+Function fpc_shortstr_to_widechararray(arraysize: SizeInt; const src: ShortString): fpc_big_widechararray; compilerproc;
+Function fpc_ansistr_to_widechararray(arraysize: SizeInt; const src: AnsiString): fpc_big_widechararray; compilerproc;
+{$else ndef FPC_STRTOCHARARRAYPROC}
+procedure fpc_shortstr_to_widechararray(out res: array of widechar; const src: ShortString); compilerproc;
+procedure fpc_ansistr_to_widechararray(out res: array of widechar; const src: AnsiString); compilerproc;
+procedure fpc_unicodestr_to_widechararray(out res: array of widechar; const src: UnicodeString); compilerproc;
+{$endif ndef FPC_STRTOCHARARRAYPROC}
+{$endif VER2_2}
+Function fpc_UnicodeStr_Compare(const S1,S2 : UnicodeString): SizeInt; compilerproc;
+Function fpc_UnicodeStr_Compare_equal(const S1,S2 : UnicodeString): SizeInt; compilerproc;
+Procedure fpc_UnicodeStr_CheckZero(p : pointer); compilerproc;
+Procedure fpc_UnicodeStr_CheckRange(len,index : SizeInt); compilerproc;
+Procedure fpc_UnicodeStr_SetLength (Var S : UnicodeString; l : SizeInt); compilerproc;
+Function fpc_unicodestr_Copy (Const S : UnicodeString; Index,Size : SizeInt) : UnicodeString;compilerproc;
+function fpc_unicodestr_Unique(Var S : Pointer): Pointer; compilerproc;
+Function fpc_Char_To_UChar(const c : Char): UnicodeChar; compilerproc;
+Function fpc_UChar_To_Char(const c : UnicodeChar): Char; compilerproc;
+Function fpc_UChar_To_UnicodeStr(const c : UnicodeChar): UnicodeString; compilerproc;
+Function fpc_WChar_To_UnicodeStr(const c : WideChar): UnicodeString; compilerproc;
+Function fpc_UChar_To_AnsiStr(const c : UnicodeChar): AnsiString; compilerproc;
{$ifndef FPC_STRTOSHORTSTRINGPROC}
Function fpc_WChar_To_ShortStr(const c : WideChar): ShortString; compilerproc;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_WChar_To_ShortStr(out res : shortstring;const c : WideChar) compilerproc;
{$endif FPC_STRTOSHORTSTRINGPROC}
-Function fpc_WChar_To_AnsiStr(const c : WideChar): AnsiString; compilerproc;
-Function fpc_WChar_To_WideStr(const c : WideChar): WideString; compilerproc;
+{$endif FPC_HAS_FEATURE_WIDESTRINGS}
+
+{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
+{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
+Function fpc_PUnicodeChar_To_AnsiStr(const p : punicodechar): ansistring; compilerproc;
+{$endif FPC_HAS_FEATURE_ANSISTRINGS}
+Function fpc_PUnicodeChar_To_UnicodeStr(const p : punicodechar): unicodestring; compilerproc;
+Function fpc_PWideChar_To_UnicodeStr(const p : pwidechar): unicodestring; compilerproc;
+{$ifndef FPC_STRTOSHORTSTRINGPROC}
+Function fpc_PUnicodeChar_To_ShortStr(const p : punicodechar): shortstring; compilerproc;
+{$else FPC_STRTOSHORTSTRINGPROC}
+procedure fpc_PUnicodeChar_To_ShortStr(out res : shortstring;const p : punicodechar); compilerproc;
+{$endif FPC_STRTOSHORTSTRINGPROC}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Function fpc_PWideChar_To_AnsiStr(const p : pwidechar): ansistring; compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
-Function fpc_PWideChar_To_WideStr(const p : pwidechar): widestring; compilerproc;
{$ifndef FPC_STRTOSHORTSTRINGPROC}
Function fpc_PWideChar_To_ShortStr(const p : pwidechar): shortstring; compilerproc;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_PWideChar_To_ShortStr(out res : shortstring;const p : pwidechar); compilerproc;
{$endif FPC_STRTOSHORTSTRINGPROC}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
+{$endif VER2_2}
+
+{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
+Function fpc_Char_To_WChar(const c : Char): WideChar; compilerproc;
+Function fpc_WChar_To_Char(const c : WideChar): Char; compilerproc;
+{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifdef FPC_HAS_FEATURE_TEXTIO}
{ from text.inc }
@@ -325,7 +466,10 @@ Procedure fpc_Write_Text_ShortStr(Len : Longint;var f : Text;const s : String);
Procedure fpc_Write_Text_Pchar_as_Array(Len : Longint;var f : Text;const s : array of char; zerobased: boolean = true); compilerproc;
Procedure fpc_Write_Text_PChar_As_Pointer(Len : Longint;var f : Text;p : PChar); compilerproc;
Procedure fpc_Write_Text_AnsiStr (Len : Longint; Var f : Text; const S : AnsiString); compilerproc;
+{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
Procedure fpc_Write_Text_WideStr (Len : Longint; Var f : Text; const S : WideString); compilerproc;
+{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
+Procedure fpc_Write_Text_UnicodeStr (Len : Longint; Var f : Text; const S : WideString); compilerproc;
Procedure fpc_Write_Text_SInt(Len : Longint;var t : Text;l : ValSInt); compilerproc;
Procedure fpc_Write_Text_UInt(Len : Longint;var t : Text;l : ValUInt); compilerproc;
{$ifndef CPU64}
diff --git a/rtl/inc/rtti.inc b/rtl/inc/rtti.inc
index f2cfb6435c..c51b0afe4e 100644
--- a/rtl/inc/rtti.inc
+++ b/rtl/inc/rtti.inc
@@ -40,6 +40,9 @@ Const
tkInt64 = 19;
tkQWord = 20;
tkDynArray = 21;
+ tkInterfaceCorba = 22;
+ tkProcVar = 23;
+ tkUString = 24;
type
@@ -130,7 +133,7 @@ end;
Procedure fpc_Initialize (Data,TypeInfo : pointer);[Public,Alias : 'FPC_INITIALIZE']; compilerproc;
begin
case PByte(TypeInfo)^ of
- tkAstring,tkWstring,tkInterface,tkDynArray:
+ tkAstring,tkWstring,tkUString,tkInterface,tkDynArray:
PPchar(Data)^:=Nil;
tkArray:
arrayrtti(data,typeinfo,@int_initialize);
@@ -151,11 +154,20 @@ begin
fpc_AnsiStr_Decr_Ref(PPointer(Data)^);
PPointer(Data)^:=nil;
end;
+{$ifndef VER2_2}
+ tkUstring :
+ begin
+ fpc_UnicodeStr_Decr_Ref(PPointer(Data)^);
+ PPointer(Data)^:=nil;
+ end;
+{$endif VER2_2}
+{$ifdef WINDOWS}
tkWstring :
begin
fpc_WideStr_Decr_Ref(PPointer(Data)^);
PPointer(Data)^:=nil;
end;
+{$endif WINDOWS}
tkArray :
arrayrtti(data,typeinfo,@int_finalize);
tkObject,
@@ -179,8 +191,14 @@ begin
case PByte(TypeInfo)^ of
tkAstring :
fpc_AnsiStr_Incr_Ref(PPointer(Data)^);
+{$ifdef WINDOWS}
tkWstring :
fpc_WideStr_Incr_Ref(PPointer(Data)^);
+{$endif WINDOWS}
+{$ifndef VER2_2}
+ tkUstring :
+ fpc_UnicodeStr_Incr_Ref(PPointer(Data)^);
+{$endif VER2_2}
tkArray :
arrayrtti(data,typeinfo,@int_addref);
tkobject,
@@ -206,8 +224,14 @@ begin
{ see AddRef for comment about below construct (JM) }
tkAstring:
fpc_AnsiStr_Decr_Ref(PPointer(Data)^);
+{$ifdef WINDOWS}
tkWstring:
fpc_WideStr_Decr_Ref(PPointer(Data)^);
+{$endif WINDOWS}
+{$ifndef VER2_2}
+ tkUString:
+ fpc_UnicodeStr_Decr_Ref(PPointer(Data)^);
+{$endif VER2_2}
tkArray:
arrayrtti(data,typeinfo,@fpc_systemDecRef);
tkobject,
@@ -245,8 +269,14 @@ begin
fpc_AnsiStr_Decr_Ref(PPointer(Dest)^);
PPointer(Dest)^:=PPointer(Src)^;
end;
+{$ifdef WINDOWS}
tkWstring:
fpc_WideStr_Assign(PPointer(Dest)^,PPointer(Src)^);
+{$endif WINDOWS}
+{$ifndef VER2_2}
+ tkUstring:
+ fpc_UnicodeStr_Assign(PPointer(Dest)^,PPointer(Src)^);
+{$endif VER2_2}
tkArray:
begin
Temp:=PByte(TypeInfo);
diff --git a/rtl/inc/system.inc b/rtl/inc/system.inc
index 72512533f3..79a4590c2c 100644
--- a/rtl/inc/system.inc
+++ b/rtl/inc/system.inc
@@ -331,7 +331,15 @@ function aligntoptr(p : pointer) : pointer;inline;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
-{$i wstrings.inc}
+{ this is for bootstrappung with 2.2.x }
+{$ifdef VER2_2}
+{$i wustring22.inc}
+{$else VER2_2}
+ {$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
+ {$i wstrings.inc}
+ {$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
+ {$i ustrings.inc}
+{$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$i aliases.inc}
diff --git a/rtl/inc/systemh.inc b/rtl/inc/systemh.inc
index cd99876038..4267429816 100644
--- a/rtl/inc/systemh.inc
+++ b/rtl/inc/systemh.inc
@@ -345,6 +345,14 @@ Type
PUCS2Char = PWideChar;
PWideString = ^WideString;
+ UnicodeChar = type WideChar;
+ PUnicodeChar = ^UnicodeChar;
+{$ifdef VER2_2}
+ { this is only to avoid too much ifdefs in the code }
+ UnicodeString = type WideString;
+{$endif VER2_2}
+ PUnicodeString = ^UnicodeString;
+
{ Needed for fpc_get_output }
PText = ^Text;
@@ -761,7 +769,14 @@ function lowercase(const s : ansistring) : ansistring;
****************************************************************************}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
-{$i wstringh.inc}
+{$ifdef VER2_2}
+{$i wstring22h.inc}
+{$else VER2_2}
+ {$i ustringh.inc}
+ {$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
+ {$i wstringh.inc}
+ {$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
+{$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
diff --git a/rtl/inc/text.inc b/rtl/inc/text.inc
index 1819522e71..a73e2fe38d 100644
--- a/rtl/inc/text.inc
+++ b/rtl/inc/text.inc
@@ -617,6 +617,32 @@ begin
end;
+Procedure fpc_Write_Text_UnicodeStr (Len : Longint; Var f : Text; const S : WideString); iocheck; [Public,alias:'FPC_WRITE_TEXT_UNICODESTR']; compilerproc;
+{
+ Writes a UnicodeString to the Text file T
+}
+var
+ SLen : longint;
+ a: ansistring;
+begin
+ If (pointer(S)=nil) or (InOutRes<>0) then
+ exit;
+ case TextRec(f).mode of
+ fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }:
+ begin
+ SLen:=Length(s);
+ If Len>SLen Then
+ fpc_WriteBlanks(f,Len-SLen);
+ a:=s;
+ { length(a) can be > slen, e.g. after utf-16 -> utf-8 }
+ fpc_WriteBuffer(f,pchar(a)^,length(a));
+ end;
+ fmInput: InOutRes:=105
+ else InOutRes:=103;
+ end;
+end;
+
+{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
Procedure fpc_Write_Text_WideStr (Len : Longint; Var f : Text; const S : WideString); iocheck; [Public,alias:'FPC_WRITE_TEXT_WIDESTR']; compilerproc;
{
Writes a WideString to the Text file T
@@ -641,7 +667,7 @@ begin
else InOutRes:=103;
end;
end;
-
+{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
Procedure fpc_Write_Text_SInt(Len : Longint;var t : Text;l : ValSInt); iocheck; [Public,Alias:'FPC_WRITE_TEXT_SINT']; compilerproc;
var
diff --git a/rtl/inc/ustringh.inc b/rtl/inc/ustringh.inc
new file mode 100644
index 0000000000..8583400c1f
--- /dev/null
+++ b/rtl/inc/ustringh.inc
@@ -0,0 +1,119 @@
+{
+ This file is part of the Free Pascal run time library.
+ Copyright (c) 1999-2005 by Florian Klaempfl,
+ member of the Free Pascal development team.
+
+ This file implements support routines for UnicodeStrings 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.
+
+ **********************************************************************}
+
+
+Procedure UniqueString (Var S : UnicodeString);external name 'FPC_UNICODESTR_UNIQUE';
+Function Pos (Const Substr : UnicodeString; Const Source : UnicodeString) : SizeInt;
+Function Pos (c : Char; Const s : UnicodeString) : SizeInt;
+Function Pos (c : UnicodeChar; Const s : UnicodeString) : SizeInt;
+Function Pos (c : AnsiString; Const s : UnicodeString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+Function Pos (c : UnicodeString; Const s : AnsiString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+Function Pos (c : ShortString; Const s : UnicodeString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+
+Function UpCase(const s : UnicodeString) : UnicodeString;
+Function UpCase(c:UnicodeChar):UnicodeChar;
+
+Procedure Insert (Const Source : UnicodeString; Var S : UnicodeString; Index : SizeInt);
+Procedure Delete (Var S : UnicodeString; Index,Size: SizeInt);
+Procedure SetString (Out S : UnicodeString; Buf : PUnicodeChar; Len : SizeInt);
+Procedure SetString (Out S : UnicodeString; Buf : PChar; Len : SizeInt);
+
+function WideCharToString(S : PWideChar) : AnsiString;
+function StringToWideChar(const Src : AnsiString;Dest : PWideChar;DestSize : SizeInt) : PWideChar;
+function WideCharLenToString(S : PWideChar;Len : SizeInt) : AnsiString;
+procedure WideCharLenToStrVar(Src : PWideChar;Len : SizeInt;out Dest : AnsiString);
+procedure WideCharToStrVar(S : PWideChar;out Dest : AnsiString);
+
+function UnicodeCharToString(S : PUnicodeChar) : AnsiString;
+function StringToUnicodeChar(const Src : AnsiString;Dest : PUnicodeChar;DestSize : SizeInt) : PUnicodeChar;
+function UnicodeCharLenToString(S : PUnicodeChar;Len : SizeInt) : AnsiString;
+procedure UnicodeCharLenToStrVar(Src : PUnicodeChar;Len : SizeInt;out Dest : AnsiString);
+procedure UnicodeCharToStrVar(S : PUnicodeChar;out Dest : AnsiString);
+
+procedure DefaultUnicode2AnsiMove(source:punicodechar;var dest:ansistring;len:SizeInt);
+procedure DefaultAnsi2UnicodeMove(source:pchar;var dest:unicodestring;len:SizeInt);
+
+Type
+ { hooks for internationalization
+ please add new procedures at the end, it makes it easier to detect new procedures }
+ TUnicodeStringManager = record
+ Wide2AnsiMoveProc : procedure(source:pwidechar;var dest:ansistring;len:SizeInt);
+ Ansi2WideMoveProc : procedure(source:pchar;var dest:widestring;len:SizeInt);
+
+// UpperUTF8 : procedure(p:PUTF8String);
+
+ UpperWideStringProc : function(const S: WideString): WideString;
+// UpperUCS4 : procedure(p:PUCS4Char);
+// LowerUTF8 : procedure(p:PUTF8String);
+ LowerWideStringProc : function(const S: WideString): WideString;
+// LowerUCS4 : procedure(p:PUCS4Char);
+{
+ CompUTF8 : function(p1,p2:PUTF8String) : shortint;
+ CompUCS2 : function(p1,p2:PUCS2Char) : shortint;
+ CompUCS4 : function(p1,p2:PUC42Char) : shortint;
+}
+ CompareWideStringProc : function(const s1, s2 : WideString) : PtrInt;
+ CompareTextWideStringProc : function(const s1, s2 : WideString): PtrInt;
+ CharLengthPCharProc : function(const Str: PChar): PtrInt;
+
+ UpperAnsiStringProc : function(const s : ansistring) : ansistring;
+ LowerAnsiStringProc : function(const s : ansistring) : ansistring;
+ CompareStrAnsiStringProc : function(const S1, S2: ansistring): PtrInt;
+ CompareTextAnsiStringProc : function(const S1, S2: ansistring): PtrInt;
+ StrCompAnsiStringProc : function(S1, S2: PChar): PtrInt;
+ StrICompAnsiStringProc : function(S1, S2: PChar): PtrInt;
+ StrLCompAnsiStringProc : function(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
+ StrLICompAnsiStringProc : function(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
+ StrLowerAnsiStringProc : function(Str: PChar): PChar;
+ StrUpperAnsiStringProc : function(Str: PChar): PChar;
+ ThreadInitProc : procedure;
+ ThreadFiniProc : procedure;
+
+ { this is only different on windows }
+ Unicode2AnsiMoveProc : procedure(source:punicodechar;var dest:ansistring;len:SizeInt);
+ Ansi2UnicodeMoveProc : procedure(source:pchar;var dest:unicodestring;len:SizeInt);
+ UpperUnicodeStringProc : function(const S: UnicodeString): UnicodeString;
+ LowerUnicodeStringProc : function(const S: UnicodeString): UnicodeString;
+ CompareUnicodeStringProc : function(const s1, s2 : UnicodeString) : PtrInt;
+ CompareTextUnicodeStringProc : function(const s1, s2 : UnicodeString): PtrInt;
+ end;
+
+var
+ widestringmanager : TUnicodeStringManager;
+
+function UnicodeToUtf8(Dest: PChar; Source: PUnicodeChar; MaxBytes: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+function UnicodeToUtf8(Dest: PChar; MaxDestBytes: SizeUInt; Source: PUnicodeChar; SourceChars: SizeUInt): SizeUInt;
+function Utf8ToUnicode(Dest: PUnicodeChar; Source: PChar; MaxChars: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+function Utf8ToUnicode(Dest: PUnicodeChar; MaxDestChars: SizeUInt; Source: PChar; SourceBytes: SizeUInt): SizeUInt;
+function UTF8Encode(const s : Ansistring) : UTF8String; inline;
+function UTF8Encode(const s : UnicodeString) : UTF8String;
+function UTF8Decode(const s : UTF8String): UnicodeString;
+function AnsiToUtf8(const s : ansistring): UTF8String;{$ifdef SYSTEMINLINE}inline;{$endif}
+function Utf8ToAnsi(const s : UTF8String) : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
+function UnicodeStringToUCS4String(const s : UnicodeString) : UCS4String;
+function UCS4StringToUnicodeString(const s : UCS4String) : UnicodeString;
+function WideStringToUCS4String(const s : WideString) : UCS4String;
+function UCS4StringToWideString(const s : UCS4String) : WideString;
+
+Procedure GetWideStringManager (Var Manager : TUnicodeStringManager);
+Procedure SetWideStringManager (Const New : TUnicodeStringManager);
+Procedure SetWideStringManager (Const New : TUnicodeStringManager; Var Old: TUnicodeStringManager);
+
+Procedure GetUnicodeStringManager (Var Manager : TUnicodeStringManager);
+Procedure SetUnicodeStringManager (Const New : TUnicodeStringManager);
+Procedure SetUnicodeStringManager (Const New : TUnicodeStringManager; Var Old: TUnicodeStringManager);
+
+
diff --git a/rtl/inc/ustrings.inc b/rtl/inc/ustrings.inc
new file mode 100644
index 0000000000..c1894474b5
--- /dev/null
+++ b/rtl/inc/ustrings.inc
@@ -0,0 +1,2325 @@
+{
+ This file is part of the Free Pascal run time library.
+ Copyright (c) 1999-2005 by Florian Klaempfl,
+ member of the Free Pascal development team.
+
+ This file implements support routines for UTF-8 strings 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.
+
+ **********************************************************************}
+
+{$i wustrings.inc}
+
+{
+ This file contains the implementation of the UnicodeString type,
+ and all things that are needed for it.
+ UnicodeString is defined as a 'silent' punicodechar :
+ a punicodechar that points to :
+
+ @-8 : SizeInt for reference count;
+ @-4 : SizeInt for size; size=number of bytes, not the number of chars. Divide or multiply
+ with sizeof(UnicodeChar) to convert. This is needed to be compatible with Delphi and
+ Windows COM BSTR.
+ @ : String + Terminating #0;
+ Punicodechar(Unicodestring) 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
+ PUnicodeRec = ^TUnicodeRec;
+ TUnicodeRec = Packed Record
+ Ref : SizeInt;
+ Len : SizeInt;
+ First : UnicodeChar;
+ end;
+
+Const
+ UnicodeRecLen = SizeOf(TUnicodeRec);
+ UnicodeFirstOff = SizeOf(TUnicodeRec)-sizeof(UnicodeChar);
+
+{
+ Default UnicodeChar <-> 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 DefaultUnicode2AnsiMove(source:punicodechar;var dest:ansistring;len:SizeInt);
+var
+ i : SizeInt;
+begin
+ setlength(dest,len);
+ for i:=1 to len do
+ begin
+ if word(source^)<256 then
+ dest[i]:=char(word(source^))
+ else
+ dest[i]:='?';
+ inc(source);
+ end;
+end;
+
+
+procedure DefaultAnsi2UnicodeMove(source:pchar;var dest:unicodestring;len:SizeInt);
+var
+ i : SizeInt;
+begin
+ setlength(dest,len);
+ for i:=1 to len do
+ begin
+ dest[i]:=unicodechar(byte(source^));
+ inc(source);
+ end;
+end;
+
+
+Procedure GetUnicodeStringManager (Var Manager : TUnicodeStringManager);
+begin
+ manager:=widestringmanager;
+end;
+
+
+Procedure SetUnicodeStringManager (Const New : TUnicodeStringManager; Var Old: TUnicodeStringManager);
+begin
+ Old:=widestringmanager;
+ widestringmanager:=New;
+end;
+
+
+Procedure SetUnicodeStringManager (Const New : TUnicodeStringManager);
+begin
+ widestringmanager:=New;
+end;
+
+
+Procedure GetWideStringManager (Var Manager : TUnicodeStringManager);
+begin
+ manager:=widestringmanager;
+end;
+
+
+Procedure SetWideStringManager (Const New : TUnicodeStringManager; Var Old: TUnicodeStringManager);
+begin
+ Old:=widestringmanager;
+ widestringmanager:=New;
+end;
+
+
+Procedure SetWideStringManager (Const New : TUnicodeStringManager);
+begin
+ widestringmanager:=New;
+end;
+ {****************************************************************************
+ Internal functions, not in interface.
+****************************************************************************}
+
+
+procedure UnicodeStringError;
+ begin
+ HandleErrorFrame(204,get_frame);
+ end;
+
+
+{$ifdef UnicodeStrDebug}
+Procedure DumpUnicodeRec(S : Pointer);
+begin
+ If S=Nil then
+ Writeln ('String is nil')
+ Else
+ Begin
+ With PUnicodeRec(S-UnicodeFirstOff)^ do
+ begin
+ Write ('(Len:',len);
+ Writeln (' Ref: ',ref,')');
+ end;
+ end;
+end;
+{$endif}
+
+
+Function NewUnicodeString(Len : SizeInt) : Pointer;
+{
+ Allocate a new UnicodeString on the heap.
+ initialize it to zero length and reference count 1.
+}
+Var
+ P : Pointer;
+begin
+ GetMem(P,Len*sizeof(UnicodeChar)+UnicodeRecLen);
+ If P<>Nil then
+ begin
+ PUnicodeRec(P)^.Len:=Len*2; { Initial length }
+ PUnicodeRec(P)^.Ref:=1; { Initial Refcount }
+ PUnicodeRec(P)^.First:=#0; { Terminating #0 }
+ inc(p,UnicodeFirstOff); { Points to string now }
+ end
+ else
+ UnicodeStringError;
+ NewUnicodeString:=P;
+end;
+
+
+Procedure DisposeUnicodeString(Var S : Pointer);
+{
+ Deallocates a UnicodeString From the heap.
+}
+begin
+ If S=Nil then
+ exit;
+ Dec (S,UnicodeFirstOff);
+ Freemem(S);
+ S:=Nil;
+end;
+
+
+Procedure fpc_UnicodeStr_Decr_Ref (Var S : Pointer);[Public,Alias:'FPC_UNICODESTR_DECR_REF']; compilerproc;
+{
+ Decreases the ReferenceCount of a non constant unicodestring;
+ If the reference count is zero, deallocate the string;
+}
+Type
+ pSizeInt = ^SizeInt;
+Var
+ l : pSizeInt;
+Begin
+ { Zero string }
+ if S=Nil then
+ exit;
+ { check for constant strings ...}
+ l:=@PUnicodeRec(S-UnicodeFirstOff)^.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 ...
+ ... remove }
+ DisposeUnicodeString(S);
+end;
+
+{ alias for internal use }
+Procedure fpc_UnicodeStr_Decr_Ref (Var S : Pointer);[external name 'FPC_UNICODESTR_DECR_REF'];
+
+Procedure fpc_UnicodeStr_Incr_Ref(S : Pointer);[Public,Alias:'FPC_UNICODESTR_INCR_REF']; compilerproc;
+ Begin
+ If S=Nil then
+ exit;
+ { constant string ? }
+ If PUnicodeRec(S-UnicodeFirstOff)^.Ref<0 then
+ exit;
+ inclocked(PUnicodeRec(S-UnicodeFirstOff)^.Ref);
+ end;
+
+{ alias for internal use }
+Procedure fpc_UnicodeStr_Incr_Ref (S : Pointer);[external name 'FPC_UNICODESTR_INCR_REF'];
+
+{$ifndef FPC_STRTOSHORTSTRINGPROC}
+function fpc_UnicodeStr_To_ShortStr (high_of_res: SizeInt;const S2 : UnicodeString): shortstring;[Public, alias: 'FPC_UNICODESTR_TO_SHORTSTR']; compilerproc;
+{
+ Converts a UnicodeString to a ShortString;
+}
+Var
+ Size : SizeInt;
+ temp : ansistring;
+begin
+ result:='';
+ Size:=Length(S2);
+ if Size>0 then
+ begin
+ If Size>high_of_res then
+ Size:=high_of_res;
+ widestringmanager.Unicode2AnsiMoveProc(PUnicodeChar(S2),temp,Size);
+ result:=temp;
+ end;
+end;
+{$else FPC_STRTOSHORTSTRINGPROC}
+procedure fpc_UnicodeStr_To_ShortStr (out res: ShortString;const S2 : UnicodeString); [Public, alias: 'FPC_UNICODESTR_TO_SHORTSTR'];compilerproc;
+{
+ Converts a UnicodeString to a ShortString;
+}
+Var
+ Size : SizeInt;
+ temp : ansistring;
+begin
+ res:='';
+ Size:=Length(S2);
+ if Size>0 then
+ begin
+ If Size>high(res) then
+ Size:=high(res);
+ widestringmanager.Unicode2AnsiMoveProc(PUnicodeChar(S2),temp,Size);
+ res:=temp;
+ end;
+end;
+{$endif FPC_STRTOSHORTSTRINGPROC}
+
+
+Function fpc_ShortStr_To_UnicodeStr (Const S2 : ShortString): UnicodeString;compilerproc;
+{
+ Converts a ShortString to a UnicodeString;
+}
+Var
+ Size : SizeInt;
+begin
+ result:='';
+ Size:=Length(S2);
+ if Size>0 then
+ begin
+ widestringmanager.Ansi2UnicodeMoveProc(PChar(@S2[1]),result,Size);
+ { Terminating Zero }
+ PUnicodeChar(Pointer(fpc_ShortStr_To_UnicodeStr)+Size*sizeof(UnicodeChar))^:=#0;
+ end;
+end;
+
+
+Function fpc_UnicodeStr_To_AnsiStr (const S2 : UnicodeString): AnsiString; compilerproc;
+{
+ Converts a UnicodeString to an AnsiString
+}
+Var
+ Size : SizeInt;
+begin
+ result:='';
+ Size:=Length(S2);
+ if Size>0 then
+ widestringmanager.Unicode2AnsiMoveProc(PUnicodeChar(Pointer(S2)),result,Size);
+end;
+
+
+Function fpc_AnsiStr_To_UnicodeStr (Const S2 : AnsiString): UnicodeString; compilerproc;
+{
+ Converts an AnsiString to a UnicodeString;
+}
+Var
+ Size : SizeInt;
+begin
+ result:='';
+ Size:=Length(S2);
+ if Size>0 then
+ widestringmanager.Ansi2UnicodeMoveProc(PChar(S2),result,Size);
+end;
+
+
+Function fpc_UnicodeStr_To_WideStr (const S2 : UnicodeString): WideString; compilerproc;
+ begin
+ SetLength(Result,Length(S2));
+ Move(pointer(S2)^,Pointer(Result)^,Length(S2)*sizeof(WideChar));
+ end;
+
+
+Function fpc_WideStr_To_UnicodeStr (Const S2 : WideString): UnicodeString; compilerproc;
+ begin
+ SetLength(Result,Length(S2));
+ Move(pointer(S2)^,Pointer(Result)^,Length(S2)*sizeof(WideChar));
+ end;
+
+
+Function fpc_PUnicodeChar_To_AnsiStr(const p : punicodechar): ansistring; compilerproc;
+var
+ Size : SizeInt;
+begin
+ result:='';
+ if p=nil then
+ exit;
+ Size := IndexWord(p^, -1, 0);
+ if Size>0 then
+ widestringmanager.Unicode2AnsiMoveProc(P,result,Size);
+end;
+
+
+Function fpc_PUnicodeChar_To_UnicodeStr(const p : punicodechar): unicodestring; compilerproc;
+var
+ Size : SizeInt;
+begin
+ result:='';
+ if p=nil then
+ exit;
+ Size := IndexWord(p^, -1, 0);
+ Setlength(result,Size);
+ if Size>0 then
+ begin
+ Move(p^,PUnicodeChar(Pointer(result))^,Size*sizeof(UnicodeChar));
+ { Terminating Zero }
+ PUnicodeChar(Pointer(result)+Size*sizeof(UnicodeChar))^:=#0;
+ end;
+end;
+
+
+Function fpc_PWideChar_To_UnicodeStr(const p : pwidechar): unicodestring; compilerproc;
+var
+ Size : SizeInt;
+begin
+ result:='';
+ if p=nil then
+ exit;
+ Size := IndexWord(p^, -1, 0);
+ Setlength(result,Size);
+ if Size>0 then
+ begin
+ Move(p^,PUnicodeChar(Pointer(result))^,Size*sizeof(UnicodeChar));
+ { Terminating Zero }
+ PUnicodeChar(Pointer(result)+Size*sizeof(UnicodeChar))^:=#0;
+ end;
+end;
+
+
+{$ifndef FPC_STRTOSHORTSTRINGPROC}
+Function fpc_PUnicodeChar_To_ShortStr(const p : punicodechar): shortstring; compilerproc;
+var
+ Size : SizeInt;
+ temp: ansistring;
+begin
+ result:='';
+ if p=nil then
+ exit;
+ Size := IndexWord(p^, $7fffffff, 0);
+ if Size>0 then
+ begin
+ widestringmanager.Unicode2AnsiMoveProc(p,temp,Size);
+ result:=temp;
+ end;
+end;
+{$else FPC_STRTOSHORTSTRINGPROC}
+procedure fpc_PUnicodeChar_To_ShortStr(out res : shortstring;const p : punicodechar); compilerproc;
+var
+ Size : SizeInt;
+ temp: ansistring;
+begin
+ res:='';
+ if p=nil then
+ exit;
+ Size:=IndexWord(p^, high(PtrInt), 0);
+ if Size>0 then
+ begin
+ widestringmanager.Unicode2AnsiMoveProc(p,temp,Size);
+ res:=temp;
+ end;
+end;
+{$endif FPC_STRTOSHORTSTRINGPROC}
+
+
+Function fpc_PWideChar_To_AnsiStr(const p : pwidechar): ansistring; compilerproc;
+var
+ Size : SizeInt;
+begin
+ result:='';
+ if p=nil then
+ exit;
+ Size := IndexWord(p^, -1, 0);
+ if Size>0 then
+ widestringmanager.Wide2AnsiMoveProc(P,result,Size);
+end;
+
+
+{$ifndef FPC_STRTOSHORTSTRINGPROC}
+Function fpc_PWideChar_To_ShortStr(const p : pwidechar): shortstring; compilerproc;
+var
+ Size : SizeInt;
+ temp: ansistring;
+begin
+ result:='';
+ if p=nil then
+ exit;
+ Size := IndexWord(p^, $7fffffff, 0);
+ if Size>0 then
+ begin
+ widestringmanager.Wide2AnsiMoveProc(p,temp,Size);
+ result:=temp;
+ end;
+end;
+{$else FPC_STRTOSHORTSTRINGPROC}
+procedure fpc_PWideChar_To_ShortStr(out res : shortstring;const p : pwidechar); compilerproc;
+var
+ Size : SizeInt;
+ temp: ansistring;
+begin
+ res:='';
+ if p=nil then
+ exit;
+ Size:=IndexWord(p^, high(PtrInt), 0);
+ if Size>0 then
+ begin
+ widestringmanager.Wide2AnsiMoveProc(p,temp,Size);
+ res:=temp;
+ end;
+end;
+{$endif FPC_STRTOSHORTSTRINGPROC}
+
+
+{ checked against the ansistring routine, 2001-05-27 (FK) }
+Procedure fpc_UnicodeStr_Assign (Var S1 : Pointer;S2 : Pointer);[Public,Alias:'FPC_UNICODESTR_ASSIGN']; compilerproc;
+{
+ Assigns S2 to S1 (S1:=S2), taking in account reference counts.
+}
+begin
+ If S2<>nil then
+ If PUnicodeRec(S2-UnicodeFirstOff)^.Ref>0 then
+ inclocked(PUnicodeRec(S2-UnicodeFirstOff)^.ref);
+ { Decrease the reference count on the old S1 }
+ fpc_unicodestr_decr_ref (S1);
+ s1:=s2;
+end;
+
+
+{ alias for internal use }
+Procedure fpc_UnicodeStr_Assign (Var S1 : Pointer;S2 : Pointer);[external name 'FPC_UNICODESTR_ASSIGN'];
+
+{$ifndef STR_CONCAT_PROCS}
+
+function fpc_UnicodeStr_Concat (const S1,S2 : UnicodeString): UnicodeString; compilerproc;
+Var
+ Size,Location : SizeInt;
+ pc : punicodechar;
+begin
+ { only assign if s1 or s2 is empty }
+ if (S1='') then
+ begin
+ result:=s2;
+ exit;
+ end;
+ if (S2='') then
+ begin
+ result:=s1;
+ exit;
+ end;
+ Location:=Length(S1);
+ Size:=length(S2);
+ SetLength(result,Size+Location);
+ pc:=punicodechar(result);
+ Move(S1[1],pc^,Location*sizeof(UnicodeChar));
+ inc(pc,location);
+ Move(S2[1],pc^,(Size+1)*sizeof(UnicodeChar));
+end;
+
+
+function fpc_UnicodeStr_Concat_multi (const sarr:array of Unicodestring): unicodestring; compilerproc;
+Var
+ i : Longint;
+ p : pointer;
+ pc : punicodechar;
+ Size,NewSize : SizeInt;
+begin
+ { First calculate size of the result so we can do
+ a single call to SetLength() }
+ NewSize:=0;
+ for i:=low(sarr) to high(sarr) do
+ inc(Newsize,length(sarr[i]));
+ SetLength(result,NewSize);
+ pc:=punicodechar(result);
+ for i:=low(sarr) to high(sarr) do
+ begin
+ p:=pointer(sarr[i]);
+ if assigned(p) then
+ begin
+ Size:=length(unicodestring(p));
+ Move(punicodechar(p)^,pc^,(Size+1)*sizeof(UnicodeChar));
+ inc(pc,size);
+ end;
+ end;
+end;
+
+{$else STR_CONCAT_PROCS}
+
+procedure fpc_UnicodeStr_Concat (var DestS:Unicodestring;const S1,S2 : UnicodeString); compilerproc;
+Var
+ Size,Location : SizeInt;
+ same : boolean;
+begin
+ { only assign if s1 or s2 is empty }
+ if (S1='') then
+ begin
+ DestS:=s2;
+ exit;
+ end;
+ if (S2='') then
+ begin
+ DestS:=s1;
+ exit;
+ end;
+ Location:=Length(S1);
+ Size:=length(S2);
+ { Use Pointer() typecasts to prevent extra conversion code }
+ if Pointer(DestS)=Pointer(S1) then
+ begin
+ same:=Pointer(S1)=Pointer(S2);
+ SetLength(DestS,Size+Location);
+ if same then
+ Move(Pointer(DestS)^,(Pointer(DestS)+Location*sizeof(UnicodeChar))^,(Size)*sizeof(UnicodeChar))
+ else
+ Move(Pointer(S2)^,(Pointer(DestS)+Location*sizeof(UnicodeChar))^,(Size+1)*sizeof(UnicodeChar));
+ end
+ else if Pointer(DestS)=Pointer(S2) then
+ begin
+ SetLength(DestS,Size+Location);
+ Move(Pointer(DestS)^,(Pointer(DestS)+Location*sizeof(UnicodeChar))^,(Size+1)*sizeof(UnicodeChar));
+ Move(Pointer(S1)^,Pointer(DestS)^,Location*sizeof(UnicodeChar));
+ end
+ else
+ begin
+ DestS:='';
+ SetLength(DestS,Size+Location);
+ Move(Pointer(S1)^,Pointer(DestS)^,Location*sizeof(UnicodeChar));
+ Move(Pointer(S2)^,(Pointer(DestS)+Location*sizeof(UnicodeChar))^,(Size+1)*sizeof(UnicodeChar));
+ end;
+end;
+
+
+procedure fpc_UnicodeStr_Concat_multi (var DestS:Unicodestring;const sarr:array of Unicodestring); compilerproc;
+Var
+ i : Longint;
+ p,pc : pointer;
+ Size,NewLen : SizeInt;
+ lowstart : longint;
+ destcopy : pointer;
+ OldDestLen : SizeInt;
+begin
+ if high(sarr)=0 then
+ begin
+ DestS:='';
+ exit;
+ end;
+ destcopy:=nil;
+ lowstart:=low(sarr);
+ if Pointer(DestS)=Pointer(sarr[lowstart]) then
+ inc(lowstart);
+ { Check for another reuse, then we can't use
+ the append optimization }
+ for i:=lowstart to high(sarr) do
+ begin
+ if Pointer(DestS)=Pointer(sarr[i]) then
+ begin
+ { if DestS is used somewhere in the middle of the expression,
+ we need to make sure the original string still exists after
+ we empty/modify DestS.
+ This trick only works with reference counted strings. Therefor
+ this optimization is disabled for WINLIKEUNICODESTRING }
+ destcopy:=pointer(dests);
+ fpc_UnicodeStr_Incr_Ref(destcopy);
+ lowstart:=low(sarr);
+ break;
+ end;
+ end;
+ { Start with empty DestS if we start with concatting
+ the first array element }
+ if lowstart=low(sarr) then
+ DestS:='';
+ OldDestLen:=length(DestS);
+ { Calculate size of the result so we can do
+ a single call to SetLength() }
+ NewLen:=0;
+ for i:=low(sarr) to high(sarr) do
+ inc(NewLen,length(sarr[i]));
+ SetLength(DestS,NewLen);
+ { Concat all strings, except the string we already
+ copied in DestS }
+ pc:=Pointer(DestS)+OldDestLen*sizeof(UnicodeChar);
+ for i:=lowstart to high(sarr) do
+ begin
+ p:=pointer(sarr[i]);
+ if assigned(p) then
+ begin
+ Size:=length(unicodestring(p));
+ Move(p^,pc^,(Size+1)*sizeof(UnicodeChar));
+ inc(pc,size*sizeof(UnicodeChar));
+ end;
+ end;
+ fpc_UnicodeStr_Decr_Ref(destcopy);
+end;
+
+{$endif STR_CONCAT_PROCS}
+
+Function fpc_Char_To_UChar(const c : Char): UnicodeChar; compilerproc;
+var
+ w: unicodestring;
+begin
+ widestringmanager.Ansi2UnicodeMoveProc(@c, w, 1);
+ fpc_Char_To_UChar:= w[1];
+end;
+
+
+
+Function fpc_Char_To_UnicodeStr(const c : Char): UnicodeString; compilerproc;
+{
+ Converts a Char to a UnicodeString;
+}
+begin
+ Setlength(fpc_Char_To_UnicodeStr,1);
+ fpc_Char_To_UnicodeStr[1]:=c;
+ { Terminating Zero }
+ PUnicodeChar(Pointer(fpc_Char_To_UnicodeStr)+sizeof(UnicodeChar))^:=#0;
+end;
+
+
+Function fpc_UChar_To_Char(const c : UnicodeChar): Char; compilerproc;
+{
+ Converts a UnicodeChar to a Char;
+}
+var
+ s: ansistring;
+begin
+ widestringmanager.Unicode2AnsiMoveProc(@c, s, 1);
+ if length(s)=1 then
+ fpc_UChar_To_Char:= s[1]
+ else
+ fpc_UChar_To_Char:='?';
+end;
+
+
+Function fpc_WChar_To_UnicodeStr(const c : WideChar): UnicodeString; compilerproc;
+{
+ Converts a WideChar to a UnicodeString;
+}
+begin
+ Setlength (Result,1);
+ Result[1]:= c;
+end;
+
+
+Function fpc_Char_To_WChar(const c : Char): WideChar; compilerproc;
+var
+ w: widestring;
+begin
+ widestringmanager.Ansi2WideMoveProc(@c, w, 1);
+ fpc_Char_To_WChar:= w[1];
+end;
+
+
+Function fpc_WChar_To_Char(const c : WideChar): Char; compilerproc;
+{
+ Converts a WideChar to a Char;
+}
+var
+ s: ansistring;
+begin
+ widestringmanager.Wide2AnsiMoveProc(@c, s, 1);
+ if length(s)=1 then
+ fpc_WChar_To_Char:= s[1]
+ else
+ fpc_WChar_To_Char:='?';
+end;
+
+
+{$ifndef FPC_STRTOSHORTSTRINGPROC}
+Function fpc_WChar_To_ShortStr(const c : WideChar): ShortString; compilerproc;
+{
+ Converts a WideChar to a ShortString;
+}
+var
+ s: ansistring;
+begin
+ widestringmanager.Wide2AnsiMoveProc(@c, s, 1);
+ fpc_WChar_To_ShortStr:= s;
+end;
+{$else FPC_STRTOSHORTSTRINGPROC}
+procedure fpc_WChar_To_ShortStr(out res : shortstring;const c : WideChar) compilerproc;
+{
+ Converts a WideChar to a ShortString;
+}
+var
+ s: ansistring;
+begin
+ widestringmanager.Wide2AnsiMoveProc(@c,s,1);
+ res:=s;
+end;
+{$endif FPC_STRTOSHORTSTRINGPROC}
+
+
+Function fpc_UChar_To_UnicodeStr(const c : UnicodeChar): UnicodeString; compilerproc;
+{
+ Converts a UnicodeChar to a UnicodeString;
+}
+begin
+ Setlength (fpc_UChar_To_UnicodeStr,1);
+ fpc_UChar_To_UnicodeStr[1]:= c;
+end;
+
+
+Function fpc_UChar_To_AnsiStr(const c : UnicodeChar): AnsiString; compilerproc;
+{
+ Converts a UnicodeChar to a AnsiString;
+}
+begin
+ widestringmanager.Unicode2AnsiMoveProc(@c, fpc_UChar_To_AnsiStr, 1);
+end;
+
+
+{$ifndef FPC_STRTOSHORTSTRINGPROC}
+Function fpc_UChar_To_ShortStr(const c : UnicodeChar): ShortString; compilerproc;
+{
+ Converts a UnicodeChar to a ShortString;
+}
+var
+ s: ansistring;
+begin
+ widestringmanager.Unicode2AnsiMoveProc(@c, s, 1);
+ fpc_UChar_To_ShortStr:= s;
+end;
+{$else FPC_STRTOSHORTSTRINGPROC}
+procedure fpc_UChar_To_ShortStr(out res : shortstring;const c : UnicodeChar) compilerproc;
+{
+ Converts a UnicodeChar to a ShortString;
+}
+var
+ s: ansistring;
+begin
+ widestringmanager.Unicode2AnsiMoveProc(@c,s,1);
+ res:=s;
+end;
+{$endif FPC_STRTOSHORTSTRINGPROC}
+
+
+Function fpc_PChar_To_UnicodeStr(const p : pchar): UnicodeString; compilerproc;
+Var
+ L : SizeInt;
+begin
+ if (not assigned(p)) or (p[0]=#0) Then
+ begin
+ fpc_pchar_to_unicodestr := '';
+ exit;
+ end;
+ l:=IndexChar(p^,-1,#0);
+ widestringmanager.Ansi2UnicodeMoveProc(P,fpc_PChar_To_UnicodeStr,l);
+end;
+
+
+Function fpc_CharArray_To_UnicodeStr(const arr: array of char; zerobased: boolean = true): UnicodeString; compilerproc;
+var
+ i : SizeInt;
+begin
+ if (zerobased) then
+ begin
+ if (arr[0]=#0) Then
+ begin
+ fpc_chararray_to_unicodestr := '';
+ exit;
+ end;
+ i:=IndexChar(arr,high(arr)+1,#0);
+ if i = -1 then
+ i := high(arr)+1;
+ end
+ else
+ i := high(arr)+1;
+ SetLength(fpc_CharArray_To_UnicodeStr,i);
+ widestringmanager.Ansi2UnicodeMoveProc (pchar(@arr),fpc_CharArray_To_UnicodeStr,i);
+end;
+
+
+{$ifndef FPC_STRTOSHORTSTRINGPROC}
+function fpc_UnicodeCharArray_To_ShortStr(const arr: array of unicodechar; zerobased: boolean = true): shortstring;[public,alias:'FPC_UNICODECHARARRAY_TO_SHORTSTR']; compilerproc;
+var
+ l: longint;
+ index: longint;
+ len: byte;
+ temp: ansistring;
+begin
+ l := high(arr)+1;
+ if l>=256 then
+ l:=255
+ else if l<0 then
+ l:=0;
+ if zerobased then
+ begin
+ index:=IndexWord(arr[0],l,0);
+ if (index < 0) then
+ len := l
+ else
+ len := index;
+ end
+ else
+ len := l;
+ widestringmanager.Unicode2AnsiMoveProc (punicodechar(@arr),temp,len);
+ fpc_UnicodeCharArray_To_ShortStr := temp;
+end;
+{$else FPC_STRTOSHORTSTRINGPROC}
+procedure fpc_UnicodeCharArray_To_ShortStr(out res : shortstring;const arr: array of unicodechar; zerobased: boolean = true);[public,alias:'FPC_UNICODECHARARRAY_TO_SHORTSTR']; compilerproc;
+var
+ l: longint;
+ index: ptrint;
+ len: byte;
+ temp: ansistring;
+begin
+ l := high(arr)+1;
+ if l>=high(res)+1 then
+ l:=high(res)
+ else if l<0 then
+ l:=0;
+ if zerobased then
+ begin
+ index:=IndexWord(arr[0],l,0);
+ if index<0 then
+ len:=l
+ else
+ len:=index;
+ end
+ else
+ len:=l;
+ widestringmanager.Unicode2AnsiMoveProc (punicodechar(@arr),temp,len);
+ res:=temp;
+end;
+{$endif FPC_STRTOSHORTSTRINGPROC}
+
+Function fpc_UnicodeCharArray_To_AnsiStr(const arr: array of unicodechar; zerobased: boolean = true): AnsiString; compilerproc;
+var
+ i : SizeInt;
+begin
+ if (zerobased) then
+ begin
+ i:=IndexWord(arr,high(arr)+1,0);
+ if i = -1 then
+ i := high(arr)+1;
+ end
+ else
+ i := high(arr)+1;
+ SetLength(fpc_UnicodeCharArray_To_AnsiStr,i);
+ widestringmanager.Unicode2AnsiMoveProc (punicodechar(@arr),fpc_UnicodeCharArray_To_AnsiStr,i);
+end;
+
+
+Function fpc_UnicodeCharArray_To_UnicodeStr(const arr: array of unicodechar; zerobased: boolean = true): UnicodeString; compilerproc;
+var
+ i : SizeInt;
+begin
+ if (zerobased) then
+ begin
+ i:=IndexWord(arr,high(arr)+1,0);
+ if i = -1 then
+ i := high(arr)+1;
+ end
+ else
+ i := high(arr)+1;
+ SetLength(fpc_UnicodeCharArray_To_UnicodeStr,i);
+ Move(arr[0], Pointer(fpc_UnicodeCharArray_To_UnicodeStr)^,i*sizeof(UnicodeChar));
+end;
+
+
+Function fpc_WideCharArray_To_UnicodeStr(const arr: array of widechar; zerobased: boolean = true): UnicodeString; compilerproc;
+var
+ i : SizeInt;
+begin
+ if (zerobased) then
+ begin
+ i:=IndexWord(arr,high(arr)+1,0);
+ if i = -1 then
+ i := high(arr)+1;
+ end
+ else
+ i := high(arr)+1;
+ SetLength(fpc_WideCharArray_To_UnicodeStr,i);
+ Move(arr[0], Pointer(fpc_WideCharArray_To_UnicodeStr)^,i*sizeof(WideChar));
+end;
+
+
+{ due to their names, the following procedures should be in wstrings.inc,
+ however, the compiler generates code using this functions on all platforms }
+{$ifndef FPC_STRTOSHORTSTRINGPROC}
+function fpc_WideCharArray_To_ShortStr(const arr: array of widechar; zerobased: boolean = true): shortstring;[public,alias:'FPC_WIDECHARARRAY_TO_SHORTSTR']; compilerproc;
+var
+ l: longint;
+ index: longint;
+ len: byte;
+ temp: ansistring;
+begin
+ l := high(arr)+1;
+ if l>=256 then
+ l:=255
+ else if l<0 then
+ l:=0;
+ if zerobased then
+ begin
+ index:=IndexWord(arr[0],l,0);
+ if (index < 0) then
+ len := l
+ else
+ len := index;
+ end
+ else
+ len := l;
+ widestringmanager.Wide2AnsiMoveProc (pwidechar(@arr),temp,len);
+ fpc_WideCharArray_To_ShortStr := temp;
+end;
+{$else FPC_STRTOSHORTSTRINGPROC}
+procedure fpc_WideCharArray_To_ShortStr(out res : shortstring;const arr: array of widechar; zerobased: boolean = true);[public,alias:'FPC_WIDECHARARRAY_TO_SHORTSTR']; compilerproc;
+var
+ l: longint;
+ index: ptrint;
+ len: byte;
+ temp: ansistring;
+begin
+ l := high(arr)+1;
+ if l>=high(res)+1 then
+ l:=high(res)
+ else if l<0 then
+ l:=0;
+ if zerobased then
+ begin
+ index:=IndexWord(arr[0],l,0);
+ if index<0 then
+ len:=l
+ else
+ len:=index;
+ end
+ else
+ len:=l;
+ widestringmanager.Wide2AnsiMoveProc (pwidechar(@arr),temp,len);
+ res:=temp;
+end;
+{$endif FPC_STRTOSHORTSTRINGPROC}
+
+Function fpc_WideCharArray_To_AnsiStr(const arr: array of widechar; zerobased: boolean = true): AnsiString; compilerproc;
+var
+ i : SizeInt;
+begin
+ if (zerobased) then
+ begin
+ i:=IndexWord(arr,high(arr)+1,0);
+ if i = -1 then
+ i := high(arr)+1;
+ end
+ else
+ i := high(arr)+1;
+ SetLength(fpc_WideCharArray_To_AnsiStr,i);
+ widestringmanager.Wide2AnsiMoveProc (pwidechar(@arr),fpc_WideCharArray_To_AnsiStr,i);
+end;
+
+Function fpc_WideCharArray_To_WideStr(const arr: array of widechar; zerobased: boolean = true): WideString; compilerproc;
+var
+ i : SizeInt;
+begin
+ if (zerobased) then
+ begin
+ i:=IndexWord(arr,high(arr)+1,0);
+ if i = -1 then
+ i := high(arr)+1;
+ end
+ else
+ i := high(arr)+1;
+ SetLength(fpc_WideCharArray_To_WideStr,i);
+ Move(arr[0], Pointer(fpc_WideCharArray_To_WideStr)^,i*sizeof(WideChar));
+end;
+
+{$ifndef FPC_STRTOCHARARRAYPROC}
+
+{ inside the compiler, the resulttype is modified to that of the actual }
+{ chararray we're converting to (JM) }
+function fpc_unicodestr_to_chararray(arraysize: SizeInt; const src: UnicodeString): fpc_big_chararray;[public,alias: 'FPC_UNICODESTR_TO_CHARARRAY']; compilerproc;
+var
+ len: SizeInt;
+ temp: ansistring;
+begin
+ len := length(src);
+ { make sure we don't dereference src if it can be nil (JM) }
+ if len > 0 then
+ widestringmanager.unicode2ansimoveproc(punicodechar(@src[1]),temp,len);
+ len := length(temp);
+ if len > arraysize then
+ len := arraysize;
+{$r-}
+ move(temp[1],fpc_unicodestr_to_chararray[0],len);
+ fillchar(fpc_unicodestr_to_chararray[len],arraysize-len,0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+
+{ inside the compiler, the resulttype is modified to that of the actual }
+{ unicodechararray we're converting to (JM) }
+function fpc_unicodestr_to_unicodechararray(arraysize: SizeInt; const src: UnicodeString): fpc_big_unicodechararray;[public,alias: 'FPC_UNICODESTR_TO_UNICODECHARARRAY']; compilerproc;
+var
+ len: SizeInt;
+begin
+ len := length(src);
+ if len > arraysize then
+ len := arraysize;
+{$r-}
+ { make sure we don't try to access element 1 of the ansistring if it's nil }
+ if len > 0 then
+ move(src[1],fpc_unicodestr_to_unicodechararray[0],len*SizeOf(UnicodeChar));
+ fillchar(fpc_unicodestr_to_unicodechararray[len],(arraysize-len)*SizeOf(UnicodeChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+
+{ inside the compiler, the resulttype is modified to that of the actual }
+{ chararray we're converting to (JM) }
+function fpc_ansistr_to_unicodechararray(arraysize: SizeInt; const src: AnsiString): fpc_big_unicodechararray;[public,alias: 'FPC_ANSISTR_TO_UNICODECHARARRAY']; compilerproc;
+var
+ len: SizeInt;
+ temp: unicodestring;
+begin
+ len := length(src);
+ { make sure we don't dereference src if it can be nil (JM) }
+ if len > 0 then
+ widestringmanager.ansi2unicodemoveproc(pchar(@src[1]),temp,len);
+ len := length(temp);
+ if len > arraysize then
+ len := arraysize;
+
+{$r-}
+ move(temp[1],fpc_ansistr_to_unicodechararray[0],len*sizeof(unicodechar));
+ fillchar(fpc_ansistr_to_unicodechararray[len],(arraysize-len)*SizeOf(UnicodeChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+function fpc_shortstr_to_unicodechararray(arraysize: SizeInt; const src: ShortString): fpc_big_unicodechararray;[public,alias: 'FPC_SHORTSTR_TO_UNICODECHARARRAY']; compilerproc;
+var
+ len: longint;
+ temp : unicodestring;
+begin
+ len := length(src);
+ { make sure we don't access char 1 if length is 0 (JM) }
+ if len > 0 then
+ widestringmanager.ansi2unicodemoveproc(pchar(@src[1]),temp,len);
+ len := length(temp);
+ if len > arraysize then
+ len := arraysize;
+{$r-}
+ move(temp[1],fpc_shortstr_to_unicodechararray[0],len*sizeof(unicodechar));
+ fillchar(fpc_shortstr_to_unicodechararray[len],(arraysize-len)*SizeOf(UnicodeChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+{$else ndef FPC_STRTOCHARARRAYPROC}
+
+procedure fpc_unicodestr_to_chararray(out res: array of char; const src: UnicodeString); compilerproc;
+var
+ len: SizeInt;
+ temp: ansistring;
+begin
+ len := length(src);
+ { make sure we don't dereference src if it can be nil (JM) }
+ if len > 0 then
+ widestringmanager.unicode2ansimoveproc(punicodechar(@src[1]),temp,len);
+ len := length(temp);
+ if len > length(res) then
+ len := length(res);
+{$r-}
+ move(temp[1],res[0],len);
+ fillchar(res[len],length(res)-len,0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+
+procedure fpc_unicodestr_to_unicodechararray(out res: array of unicodechar; const src: UnicodeString); compilerproc;
+var
+ len: SizeInt;
+begin
+ len := length(src);
+ if len > length(res) then
+ len := length(res);
+{$r-}
+ { make sure we don't try to access element 1 of the ansistring if it's nil }
+ if len > 0 then
+ move(src[1],res[0],len*SizeOf(UnicodeChar));
+ fillchar(res[len],(length(res)-len)*SizeOf(UnicodeChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+
+procedure fpc_ansistr_to_unicodechararray(out res: array of unicodechar; const src: AnsiString); compilerproc;
+var
+ len: SizeInt;
+ temp: unicodestring;
+begin
+ len := length(src);
+ { make sure we don't dereference src if it can be nil (JM) }
+ if len > 0 then
+ widestringmanager.ansi2unicodemoveproc(pchar(@src[1]),temp,len);
+ len := length(temp);
+ if len > length(res) then
+ len := length(res);
+
+{$r-}
+ move(temp[1],res[0],len*sizeof(unicodechar));
+ fillchar(res[len],(length(res)-len)*SizeOf(UnicodeChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+procedure fpc_shortstr_to_unicodechararray(out res: array of unicodechar; const src: ShortString); compilerproc;
+var
+ len: longint;
+ temp : unicodestring;
+begin
+ len := length(src);
+ { make sure we don't access char 1 if length is 0 (JM) }
+ if len > 0 then
+ widestringmanager.ansi2unicodemoveproc(pchar(@src[1]),temp,len);
+ len := length(temp);
+ if len > length(res) then
+ len := length(res);
+{$r-}
+ move(temp[1],res[0],len*sizeof(unicodechar));
+ fillchar(res[len],(length(res)-len)*SizeOf(UnicodeChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+procedure fpc_ansistr_to_widechararray(out res: array of widechar; const src: AnsiString); compilerproc;
+var
+ len: SizeInt;
+ temp: widestring;
+begin
+ len := length(src);
+ { make sure we don't dereference src if it can be nil (JM) }
+ if len > 0 then
+ widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
+ len := length(temp);
+ if len > length(res) then
+ len := length(res);
+
+{$r-}
+ move(temp[1],res[0],len*sizeof(widechar));
+ fillchar(res[len],(length(res)-len)*SizeOf(WideChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+procedure fpc_shortstr_to_widechararray(out res: array of widechar; const src: ShortString); compilerproc;
+var
+ len: longint;
+ temp : widestring;
+begin
+ len := length(src);
+ { make sure we don't access char 1 if length is 0 (JM) }
+ if len > 0 then
+ widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
+ len := length(temp);
+ if len > length(res) then
+ len := length(res);
+{$r-}
+ move(temp[1],res[0],len*sizeof(widechar));
+ fillchar(res[len],(length(res)-len)*SizeOf(WideChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+
+procedure fpc_unicodestr_to_widechararray(out res: array of widechar; const src: UnicodeString); compilerproc;
+var
+ len: SizeInt;
+begin
+ len := length(src);
+ if len > length(res) then
+ len := length(res);
+{$r-}
+ { make sure we don't try to access element 1 of the widestring if it's nil }
+ if len > 0 then
+ move(src[1],res[0],len*SizeOf(WideChar));
+ fillchar(res[len],(length(res)-len)*SizeOf(WideChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+
+{$endif ndef FPC_STRTOCHARARRAYPROC}
+
+Function fpc_UnicodeStr_Compare(const S1,S2 : UnicodeString): SizeInt;[Public,Alias : 'FPC_UNICODESTR_COMPARE']; compilerproc;
+{
+ Compares 2 UnicodeStrings;
+ The result is
+ <0 if S1<S2
+ 0 if S1=S2
+ >0 if S1>S2
+}
+Var
+ MaxI,Temp : SizeInt;
+begin
+ if pointer(S1)=pointer(S2) then
+ begin
+ fpc_UnicodeStr_Compare:=0;
+ exit;
+ end;
+ Maxi:=Length(S1);
+ temp:=Length(S2);
+ If MaxI>Temp then
+ MaxI:=Temp;
+ Temp:=CompareWord(S1[1],S2[1],MaxI);
+ if temp=0 then
+ temp:=Length(S1)-Length(S2);
+ fpc_UnicodeStr_Compare:=Temp;
+end;
+
+Function fpc_UnicodeStr_Compare_Equal(const S1,S2 : UnicodeString): SizeInt;[Public,Alias : 'FPC_UNICODESTR_COMPARE_EQUAL']; compilerproc;
+{
+ Compares 2 UnicodeStrings for equality only;
+ The result is
+ 0 if S1=S2
+ <>0 if S1<>S2
+}
+Var
+ MaxI : SizeInt;
+begin
+ if pointer(S1)=pointer(S2) then
+ exit(0);
+ Maxi:=Length(S1);
+ If MaxI<>Length(S2) then
+ exit(-1)
+ else
+ exit(CompareWord(S1[1],S2[1],MaxI));
+end;
+
+Procedure fpc_UnicodeStr_CheckZero(p : pointer);[Public,Alias : 'FPC_UNICODESTR_CHECKZERO']; compilerproc;
+begin
+ if p=nil then
+ HandleErrorFrame(201,get_frame);
+end;
+
+
+Procedure fpc_UnicodeStr_CheckRange(len,index : SizeInt);[Public,Alias : 'FPC_UNICODESTR_RANGECHECK']; compilerproc;
+begin
+ if (index>len div 2) or (Index<1) then
+ HandleErrorFrame(201,get_frame);
+end;
+
+Procedure fpc_UnicodeStr_SetLength(Var S : UnicodeString; l : SizeInt);[Public,Alias : 'FPC_UNICODESTR_SETLENGTH']; compilerproc;
+{
+ Sets The length of string S to L.
+ Makes sure S is unique, and contains enough room.
+}
+Var
+ Temp : Pointer;
+ movelen: SizeInt;
+begin
+ if (l>0) then
+ begin
+ if Pointer(S)=nil then
+ begin
+ { Need a complete new string...}
+ Pointer(s):=NewUnicodeString(l);
+ end
+ { windows doesn't support reallocing unicodestrings, this code
+ is anyways subject to be removed because unicodestrings shouldn't be
+ ref. counted anymore (FK) }
+ else
+ if (PUnicodeRec(Pointer(S)-UnicodeFirstOff)^.Ref = 1) then
+ begin
+ Dec(Pointer(S),UnicodeFirstOff);
+ if SizeUInt(L*sizeof(UnicodeChar)+UnicodeRecLen)>MemSize(Pointer(S)) then
+ reallocmem(pointer(S), L*sizeof(UnicodeChar)+UnicodeRecLen);
+ Inc(Pointer(S), UnicodeFirstOff);
+ end
+ else
+ begin
+ { Reallocation is needed... }
+ Temp:=Pointer(NewUnicodeString(L));
+ if Length(S)>0 then
+ begin
+ if l < succ(length(s)) then
+ movelen := l
+ { also move terminating null }
+ else
+ movelen := succ(length(s));
+ Move(Pointer(S)^,Temp^,movelen * Sizeof(UnicodeChar));
+ end;
+ fpc_unicodestr_decr_ref(Pointer(S));
+ Pointer(S):=Temp;
+ end;
+ { Force nil termination in case it gets shorter }
+ PWord(Pointer(S)+l*sizeof(UnicodeChar))^:=0;
+ PUnicodeRec(Pointer(S)-UnicodeFirstOff)^.Len:=l*sizeof(UnicodeChar);
+ end
+ else
+ begin
+ { Length=0 }
+ if Pointer(S)<>nil then
+ fpc_unicodestr_decr_ref (Pointer(S));
+ Pointer(S):=Nil;
+ end;
+end;
+
+{*****************************************************************************
+ Public functions, In interface.
+*****************************************************************************}
+
+function UnicodeCharToString(S : PUnicodeChar) : AnsiString;
+ begin
+ result:=UnicodeCharLenToString(s,Length(UnicodeString(s)));
+ end;
+
+function StringToUnicodeChar(const Src : AnsiString;Dest : PUnicodeChar;DestSize : SizeInt) : PUnicodeChar;
+ var
+ temp:unicodestring;
+ begin
+ widestringmanager.Ansi2UnicodeMoveProc(PChar(Src),temp,Length(Src));
+ if Length(temp)<DestSize then
+ move(temp[1],Dest^,Length(temp)*SizeOf(UnicodeChar))
+ else
+ move(temp[1],Dest^,(DestSize-1)*SizeOf(UnicodeChar));
+
+ Dest[DestSize-1]:=#0;
+
+ result:=Dest;
+
+ end;
+
+
+function WideCharToString(S : PWideChar) : AnsiString;
+ begin
+ result:=WideCharLenToString(s,Length(WideString(s)));
+ end;
+
+
+function StringToWideChar(const Src : AnsiString;Dest : PWideChar;DestSize : SizeInt) : PWideChar;
+ var
+ temp:widestring;
+ begin
+ widestringmanager.Ansi2WideMoveProc(PChar(Src),temp,Length(Src));
+ if Length(temp)<DestSize then
+ move(temp[1],Dest^,Length(temp)*SizeOf(WideChar))
+ else
+ move(temp[1],Dest^,(DestSize-1)*SizeOf(WideChar));
+
+ Dest[DestSize-1]:=#0;
+
+ result:=Dest;
+
+ end;
+
+
+function UnicodeCharLenToString(S : PUnicodeChar;Len : SizeInt) : AnsiString;
+ begin
+ //SetLength(result,Len);
+ widestringmanager.Unicode2AnsiMoveproc(S,result,Len);
+ end;
+
+
+procedure UnicodeCharLenToStrVar(Src : PUnicodeChar;Len : SizeInt;out Dest : AnsiString);
+ begin
+ Dest:=UnicodeCharLenToString(Src,Len);
+ end;
+
+
+procedure UnicodeCharToStrVar(S : PUnicodeChar;out Dest : AnsiString);
+ begin
+ Dest:=UnicodeCharToString(S);
+ end;
+
+
+function WideCharLenToString(S : PWideChar;Len : SizeInt) : AnsiString;
+ begin
+ //SetLength(result,Len);
+ widestringmanager.Wide2AnsiMoveproc(S,result,Len);
+ end;
+
+
+procedure WideCharLenToStrVar(Src : PWideChar;Len : SizeInt;out Dest : AnsiString);
+ begin
+ Dest:=WideCharLenToString(Src,Len);
+ end;
+
+
+procedure WideCharToStrVar(S : PWideChar;out Dest : AnsiString);
+ begin
+ Dest:=WideCharToString(S);
+ end;
+
+
+Function fpc_unicodestr_Unique(Var S : Pointer): Pointer; [Public,Alias : 'FPC_UNICODESTR_UNIQUE']; compilerproc;
+{
+ Make sure reference count of S is 1,
+ using copy-on-write semantics.
+}
+Var
+ SNew : Pointer;
+ L : SizeInt;
+begin
+ pointer(result) := pointer(s);
+ If Pointer(S)=Nil then
+ exit;
+ if PUnicodeRec(Pointer(S)-UnicodeFirstOff)^.Ref<>1 then
+ begin
+ L:=PUnicodeRec(Pointer(S)-UnicodeFirstOff)^.len div sizeof(UnicodeChar);
+ SNew:=NewUnicodeString (L);
+ Move (PUnicodeChar(S)^,SNew^,(L+1)*sizeof(UnicodeChar));
+ PUnicodeRec(SNew-UnicodeFirstOff)^.len:=L * sizeof(UnicodeChar);
+ fpc_unicodestr_decr_ref (Pointer(S)); { Thread safe }
+ pointer(S):=SNew;
+ pointer(result):=SNew;
+ end;
+end;
+
+
+Function Fpc_UnicodeStr_Copy (Const S : UnicodeString; Index,Size : SizeInt) : UnicodeString;compilerproc;
+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(NewUnicodeString (Size));
+ if ResultAddress<>Nil then
+ begin
+ Move (PUnicodeChar(S)[Index],ResultAddress^,Size*sizeof(UnicodeChar));
+ PUnicodeRec(ResultAddress-UnicodeFirstOff)^.Len:=Size*sizeof(UnicodeChar);
+ PUnicodeChar(ResultAddress+Size*sizeof(UnicodeChar))^:=#0;
+ end;
+ end;
+ fpc_unicodestr_decr_ref(Pointer(fpc_unicodestr_copy));
+ Pointer(fpc_unicodestr_Copy):=ResultAddress;
+end;
+
+
+Function Pos (Const Substr : UnicodeString; Const Source : UnicodeString) : SizeInt;
+var
+ i,MaxLen : SizeInt;
+ pc : punicodechar;
+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 unicodechar alone }
+Function Pos (c : UnicodeChar; Const s : UnicodeString) : SizeInt;
+var
+ i: SizeInt;
+ pc : punicodechar;
+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;
+
+
+Function Pos (c : AnsiString; Const s : UnicodeString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ result:=Pos(UnicodeString(c),s);
+ end;
+
+
+Function Pos (c : ShortString; Const s : UnicodeString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ result:=Pos(UnicodeString(c),s);
+ end;
+
+
+Function Pos (c : UnicodeString; Const s : AnsiString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ result:=Pos(c,UnicodeString(s));
+ 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 : UnicodeString) : SizeInt;
+var
+ i: SizeInt;
+ wc : unicodechar;
+ pc : punicodechar;
+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 : UnicodeString; Index,Size: SizeInt);
+Var
+ LS : SizeInt;
+begin
+ If Length(S)=0 then
+ exit;
+ if index<=0 then
+ exit;
+ LS:=PUnicodeRec(Pointer(S)-UnicodeFirstOff)^.Len div sizeof(UnicodeChar);
+ 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(PUnicodeChar(S)[Index+Size],PUnicodeChar(S)[Index],(LS-Index-Size+1)*sizeof(UnicodeChar));
+ end;
+ Setlength(s,LS-Size);
+ end;
+end;
+
+
+Procedure Insert (Const Source : UnicodeString; Var S : UnicodeString; Index : SizeInt);
+var
+ Temp : UnicodeString;
+ LS : SizeInt;
+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) := NewUnicodeString(Length(Source)+LS);
+ SetLength(Temp,Length(Source)+LS);
+ If Index>0 then
+ move (PUnicodeChar(S)^,PUnicodeChar(Temp)^,Index*sizeof(UnicodeChar));
+ Move (PUnicodeChar(Source)^,PUnicodeChar(Temp)[Index],Length(Source)*sizeof(UnicodeChar));
+ If (LS-Index)>0 then
+ Move(PUnicodeChar(S)[Index],PUnicodeChar(temp)[Length(Source)+index],(LS-Index)*sizeof(UnicodeChar));
+ S:=Temp;
+end;
+
+
+Function UpCase(c:UnicodeChar):UnicodeChar;
+var
+ s : UnicodeString;
+begin
+ s:=c;
+ result:=widestringmanager.UpperUnicodeStringProc(s)[1];
+end;
+
+
+function UpCase(const s : UnicodeString) : UnicodeString;
+begin
+ result:=widestringmanager.UpperUnicodeStringProc(s);
+end;
+
+
+Procedure SetString (Out S : UnicodeString; Buf : PUnicodeChar; Len : SizeInt);
+var
+ BufLen: SizeInt;
+begin
+ SetLength(S,Len);
+ If (Buf<>Nil) and (Len>0) then
+ begin
+ BufLen := IndexWord(Buf^, Len+1, 0);
+ If (BufLen>0) and (BufLen < Len) then
+ Len := BufLen;
+ Move (Buf[0],S[1],Len*sizeof(UnicodeChar));
+ PUnicodeChar(Pointer(S)+Len*sizeof(UnicodeChar))^:=#0;
+ end;
+end;
+
+
+Procedure SetString (Out S : UnicodeString; Buf : PChar; Len : SizeInt);
+var
+ BufLen: SizeInt;
+begin
+ SetLength(S,Len);
+ If (Buf<>Nil) and (Len>0) then
+ begin
+ BufLen := IndexByte(Buf^, Len+1, 0);
+ If (BufLen>0) and (BufLen < Len) then
+ Len := BufLen;
+ widestringmanager.Ansi2UnicodeMoveProc(Buf,S,Len);
+ //PUnicodeChar(Pointer(S)+Len*sizeof(UnicodeChar))^:=#0;
+ end;
+end;
+
+
+{$ifndef FPUNONE}
+Function fpc_Val_Real_UnicodeStr(Const S : UnicodeString; out Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_UNICODESTR']; compilerproc;
+Var
+ SS : String;
+begin
+ fpc_Val_Real_UnicodeStr := 0;
+ if length(S) > 255 then
+ code := 256
+ else
+ begin
+ SS := S;
+ Val(SS,fpc_Val_Real_UnicodeStr,code);
+ end;
+end;
+{$endif}
+
+function fpc_val_enum_unicodestr(str2ordindex:pointer;const s:unicodestring;out code:valsint):longint;compilerproc;
+
+var ss:shortstring;
+
+begin
+ if length(s)>255 then
+ code:=256
+ else
+ begin
+ ss:=s;
+ val(ss,fpc_val_enum_unicodestr,code);
+ end;
+end;
+
+Function fpc_Val_Currency_UnicodeStr(Const S : UnicodeString; out Code : ValSInt): Currency; [public, alias:'FPC_VAL_CURRENCY_UNICODESTR']; compilerproc;
+Var
+ SS : String;
+begin
+ if length(S) > 255 then
+ begin
+ fpc_Val_Currency_UnicodeStr:=0;
+ code := 256;
+ end
+ else
+ begin
+ SS := S;
+ Val(SS,fpc_Val_Currency_UnicodeStr,code);
+ end;
+end;
+
+
+Function fpc_Val_UInt_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_UNICODESTR']; compilerproc;
+Var
+ SS : ShortString;
+begin
+ fpc_Val_UInt_UnicodeStr := 0;
+ if length(S) > 255 then
+ code := 256
+ else
+ begin
+ SS := S;
+ Val(SS,fpc_Val_UInt_UnicodeStr,code);
+ end;
+end;
+
+
+Function fpc_Val_SInt_UnicodeStr (DestSize: SizeInt; Const S : UnicodeString; out Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_UNICODESTR']; compilerproc;
+Var
+ SS : ShortString;
+begin
+ fpc_Val_SInt_UnicodeStr:=0;
+ if length(S)>255 then
+ code:=256
+ else
+ begin
+ SS := S;
+ fpc_Val_SInt_UnicodeStr := int_Val_SInt_ShortStr(DestSize,SS,Code);
+ end;
+end;
+
+
+{$ifndef CPU64}
+
+Function fpc_Val_qword_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): qword; [public, alias:'FPC_VAL_QWORD_UNICODESTR']; compilerproc;
+Var
+ SS : ShortString;
+begin
+ fpc_Val_qword_UnicodeStr:=0;
+ if length(S)>255 then
+ code:=256
+ else
+ begin
+ SS := S;
+ Val(SS,fpc_Val_qword_UnicodeStr,Code);
+ end;
+end;
+
+
+Function fpc_Val_int64_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): Int64; [public, alias:'FPC_VAL_INT64_UNICODESTR']; compilerproc;
+Var
+ SS : ShortString;
+begin
+ fpc_Val_int64_UnicodeStr:=0;
+ if length(S)>255 then
+ code:=256
+ else
+ begin
+ SS := S;
+ Val(SS,fpc_Val_int64_UnicodeStr,Code);
+ end;
+end;
+
+{$endif CPU64}
+
+
+{$ifndef FPUNONE}
+procedure fpc_UnicodeStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : UnicodeString);compilerproc;
+var
+ ss : shortstring;
+begin
+ str_real(len,fr,d,treal_type(rt),ss);
+ s:=ss;
+end;
+{$endif}
+
+procedure fpc_unicodestr_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:unicodestring);compilerproc;
+
+var ss:shortstring;
+
+begin
+ fpc_shortstr_enum(ordinal,len,typinfo,ord2strindex,ss);
+ s:=ss;
+end;
+
+{$ifdef FPC_HAS_STR_CURRENCY}
+procedure fpc_UnicodeStr_Currency(c : Currency;len,fr : SizeInt;out s : UnicodeString);compilerproc;
+var
+ ss : shortstring;
+begin
+ str(c:len:fr,ss);
+ s:=ss;
+end;
+{$endif FPC_HAS_STR_CURRENCY}
+
+Procedure fpc_UnicodeStr_SInt(v : ValSint; Len : SizeInt; out S : UnicodeString);compilerproc;
+Var
+ SS : ShortString;
+begin
+ Str (v:Len,SS);
+ S:=SS;
+end;
+
+
+Procedure fpc_UnicodeStr_UInt(v : ValUInt;Len : SizeInt; out S : UnicodeString);compilerproc;
+Var
+ SS : ShortString;
+begin
+ str(v:Len,SS);
+ S:=SS;
+end;
+
+
+{$ifndef CPU64}
+
+Procedure fpc_UnicodeStr_Int64(v : Int64; Len : SizeInt; out S : UnicodeString);compilerproc;
+Var
+ SS : ShortString;
+begin
+ Str (v:Len,SS);
+ S:=SS;
+end;
+
+
+Procedure fpc_UnicodeStr_Qword(v : Qword;Len : SizeInt; out S : UnicodeString);compilerproc;
+Var
+ SS : ShortString;
+begin
+ str(v:Len,SS);
+ S:=SS;
+end;
+
+{$endif CPU64}
+
+function UnicodeToUtf8(Dest: PChar; Source: PUnicodeChar; MaxBytes: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ if assigned(Source) then
+ Result:=UnicodeToUtf8(Dest,MaxBytes,Source,IndexWord(Source^,-1,0))
+ else
+ Result:=0;
+ end;
+
+
+function UnicodeToUtf8(Dest: PChar; MaxDestBytes: SizeUInt; Source: PUnicodeChar; SourceChars: SizeUInt): SizeUInt;
+ var
+ i,j : SizeUInt;
+ w : word;
+ begin
+ result:=0;
+ if source=nil then
+ exit;
+ i:=0;
+ j:=0;
+ if assigned(Dest) then
+ begin
+ while (i<SourceChars) and (j<MaxDestBytes) do
+ begin
+ w:=word(Source[i]);
+ case w of
+ 0..$7f:
+ begin
+ Dest[j]:=char(w);
+ inc(j);
+ end;
+ $80..$7ff:
+ begin
+ if j+1>=MaxDestBytes then
+ break;
+ Dest[j]:=char($c0 or (w shr 6));
+ Dest[j+1]:=char($80 or (w and $3f));
+ inc(j,2);
+ end;
+ else
+ begin
+ if j+2>=MaxDestBytes then
+ break;
+ Dest[j]:=char($e0 or (w shr 12));
+ Dest[j+1]:=char($80 or ((w shr 6)and $3f));
+ Dest[j+2]:=char($80 or (w and $3f));
+ inc(j,3);
+ end;
+ end;
+ inc(i);
+ end;
+
+ if j>SizeUInt(MaxDestBytes-1) then
+ j:=MaxDestBytes-1;
+
+ Dest[j]:=#0;
+ end
+ else
+ begin
+ while i<SourceChars do
+ begin
+ case word(Source[i]) of
+ $0..$7f:
+ inc(j);
+ $80..$7ff:
+ inc(j,2);
+ else
+ inc(j,3);
+ end;
+ inc(i);
+ end;
+ end;
+ result:=j+1;
+ end;
+
+
+function Utf8ToUnicode(Dest: PUnicodeChar; Source: PChar; MaxChars: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ if assigned(Source) then
+ Result:=Utf8ToUnicode(Dest,MaxChars,Source,strlen(Source))
+ else
+ Result:=0;
+ end;
+
+
+function Utf8ToUnicode(Dest: PUnicodeChar; MaxDestChars: SizeUInt; Source: PChar; SourceBytes: SizeUInt): SizeUInt;
+
+var
+ i,j : SizeUInt;
+ w: SizeUInt;
+ b : byte;
+begin
+ if not assigned(Source) then
+ begin
+ result:=0;
+ exit;
+ end;
+ result:=SizeUInt(-1);
+ i:=0;
+ j:=0;
+ if assigned(Dest) then
+ begin
+ while (j<MaxDestChars) and (i<SourceBytes) do
+ begin
+ b:=byte(Source[i]);
+ w:=b;
+ inc(i);
+ // 2 or 3 bytes?
+ if b>=$80 then
+ begin
+ w:=b and $3f;
+ if i>=SourceBytes then
+ exit;
+ // 3 bytes?
+ if (b and $20)<>0 then
+ begin
+ b:=byte(Source[i]);
+ inc(i);
+ if i>=SourceBytes then
+ exit;
+ if (b and $c0)<>$80 then
+ exit;
+ w:=(w shl 6) or (b and $3f);
+ end;
+ b:=byte(Source[i]);
+ w:=(w shl 6) or (b and $3f);
+ if (b and $c0)<>$80 then
+ exit;
+ inc(i);
+ end;
+ Dest[j]:=UnicodeChar(w);
+ inc(j);
+ end;
+ if j>=MaxDestChars then j:=MaxDestChars-1;
+ Dest[j]:=#0;
+ end
+ else
+ begin
+ while i<SourceBytes do
+ begin
+ b:=byte(Source[i]);
+ inc(i);
+ // 2 or 3 bytes?
+ if b>=$80 then
+ begin
+ if i>=SourceBytes then
+ exit;
+ // 3 bytes?
+ b := b and $3f;
+ if (b and $20)<>0 then
+ begin
+ b:=byte(Source[i]);
+ inc(i);
+ if i>=SourceBytes then
+ exit;
+ if (b and $c0)<>$80 then
+ exit;
+ end;
+ if (byte(Source[i]) and $c0)<>$80 then
+ exit;
+ inc(i);
+ end;
+ inc(j);
+ end;
+ end;
+ result:=j+1;
+end;
+
+
+function UTF8Encode(const s : Ansistring) : UTF8String; inline;
+ begin
+ Result:=UTF8Encode(UnicodeString(s));
+ end;
+
+
+function UTF8Encode(const s : UnicodeString) : UTF8String;
+ var
+ i : SizeInt;
+ hs : UTF8String;
+ begin
+ result:='';
+ if s='' then
+ exit;
+ SetLength(hs,length(s)*3);
+ i:=UnicodeToUtf8(pchar(hs),length(hs)+1,PUnicodeChar(s),length(s));
+ if i>0 then
+ begin
+ SetLength(hs,i-1);
+ result:=hs;
+ end;
+ end;
+
+
+function UTF8Decode(const s : UTF8String): UnicodeString;
+ var
+ i : SizeInt;
+ hs : UnicodeString;
+ begin
+ result:='';
+ if s='' then
+ exit;
+ SetLength(hs,length(s));
+ i:=Utf8ToUnicode(PUnicodeChar(hs),length(hs)+1,pchar(s),length(s));
+ if i>0 then
+ begin
+ SetLength(hs,i-1);
+ result:=hs;
+ end;
+ end;
+
+
+function AnsiToUtf8(const s : ansistring): UTF8String;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ Result:=Utf8Encode(s);
+ end;
+
+
+function Utf8ToAnsi(const s : UTF8String) : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ Result:=Utf8Decode(s);
+ end;
+
+
+{ converts an utf-16 code point or surrogate pair to utf-32 }
+function utf16toutf32(const S: UnicodeString; const index: SizeInt; out len: longint): UCS4Char; [public, alias: 'FPC_UTF16TOUTF32'];
+var
+ w: unicodechar;
+begin
+ { UTF-16 points in the range #$0-#$D7FF and #$E000-#$FFFF }
+ { are the same in UTF-32 }
+ w:=s[index];
+ if (w<=#$d7ff) or
+ (w>=#$e000) then
+ begin
+ result:=UCS4Char(w);
+ len:=1;
+ end
+ { valid surrogate pair? }
+ else if (w<=#$dbff) and
+ { w>=#$d7ff check not needed, checked above }
+ (index<length(s)) and
+ (s[index+1]>=#$dc00) and
+ (s[index+1]<=#$dfff) then
+ { convert the surrogate pair to UTF-32 }
+ begin
+ result:=(UCS4Char(w)-$d800) shl 10 + (UCS4Char(s[index+1])-$dc00) + $10000;
+ len:=2;
+ end
+ else
+ { invalid surrogate -> do nothing }
+ begin
+ result:=UCS4Char(w);
+ len:=1;
+ end;
+end;
+
+
+function UnicodeStringToUCS4String(const s : UnicodeString) : UCS4String;
+ var
+ i, slen,
+ destindex : SizeInt;
+ len : longint;
+ begin
+ slen:=length(s);
+ setlength(result,slen+1);
+ i:=1;
+ destindex:=0;
+ while (i<=slen) do
+ begin
+ result[destindex]:=utf16toutf32(s,i,len);
+ inc(destindex);
+ inc(i,len);
+ end;
+ { destindex <= slen (surrogate pairs may have been merged) }
+ { destindex+1 for terminating #0 (dynamic arrays are }
+ { implicitely filled with zero) }
+ setlength(result,destindex+1);
+ end;
+
+
+{ concatenates an utf-32 char to a unicodestring. S *must* be unique when entering. }
+procedure ConcatUTF32ToUnicodeStr(const nc: UCS4Char; var S: UnicodeString; var index: SizeInt);
+var
+ p : PUnicodeChar;
+begin
+ { if nc > $ffff, we need two places }
+ if (index+ord(nc > $ffff)>length(s)) then
+ if (length(s) < 10*256) then
+ setlength(s,length(s)+10)
+ else
+ setlength(s,length(s)+length(s) shr 8);
+ { we know that s is unique -> avoid uniquestring calls}
+ p:=@s[index];
+ if (nc<$ffff) then
+ begin
+ p^:=unicodechar(nc);
+ inc(index);
+ end
+ else if (dword(nc)<=$10ffff) then
+ begin
+ p^:=unicodechar((nc - $10000) shr 10 + $d800);
+ (p+1)^:=unicodechar((nc - $10000) and $3ff + $dc00);
+ inc(index,2);
+ end
+ else
+ { invalid code point }
+ begin
+ p^:='?';
+ inc(index);
+ end;
+end;
+
+
+function UCS4StringToUnicodeString(const s : UCS4String) : UnicodeString;
+ var
+ i : SizeInt;
+ resindex : SizeInt;
+ begin
+ { skip terminating #0 }
+ SetLength(result,length(s)-1);
+ resindex:=1;
+ for i:=0 to high(s)-1 do
+ ConcatUTF32ToUnicodeStr(s[i],result,resindex);
+ { adjust result length (may be too big due to growing }
+ { for surrogate pairs) }
+ setlength(result,resindex-1);
+ end;
+
+
+function WideStringToUCS4String(const s : WideString) : UCS4String;
+ var
+ i, slen,
+ destindex : SizeInt;
+ len : longint;
+ begin
+ slen:=length(s);
+ setlength(result,slen+1);
+ i:=1;
+ destindex:=0;
+ while (i<=slen) do
+ begin
+ result[destindex]:=utf16toutf32(s,i,len);
+ inc(destindex);
+ inc(i,len);
+ end;
+ { destindex <= slen (surrogate pairs may have been merged) }
+ { destindex+1 for terminating #0 (dynamic arrays are }
+ { implicitely filled with zero) }
+ setlength(result,destindex+1);
+ end;
+
+
+{ concatenates an utf-32 char to a widestring. S *must* be unique when entering. }
+procedure ConcatUTF32ToWideStr(const nc: UCS4Char; var S: WideString; var index: SizeInt);
+var
+ p : PWideChar;
+begin
+ { if nc > $ffff, we need two places }
+ if (index+ord(nc > $ffff)>length(s)) then
+ if (length(s) < 10*256) then
+ setlength(s,length(s)+10)
+ else
+ setlength(s,length(s)+length(s) shr 8);
+ { we know that s is unique -> avoid uniquestring calls}
+ p:=@s[index];
+ if (nc<$ffff) then
+ begin
+ p^:=widechar(nc);
+ inc(index);
+ end
+ else if (dword(nc)<=$10ffff) then
+ begin
+ p^:=widechar((nc - $10000) shr 10 + $d800);
+ (p+1)^:=widechar((nc - $10000) and $3ff + $dc00);
+ inc(index,2);
+ end
+ else
+ { invalid code point }
+ begin
+ p^:='?';
+ inc(index);
+ end;
+end;
+
+
+function UCS4StringToWideString(const s : UCS4String) : WideString;
+ var
+ i : SizeInt;
+ resindex : SizeInt;
+ begin
+ { skip terminating #0 }
+ SetLength(result,length(s)-1);
+ resindex:=1;
+ for i:=0 to high(s)-1 do
+ ConcatUTF32ToWideStr(s[i],result,resindex);
+ { adjust result length (may be too big due to growing }
+ { for surrogate pairs) }
+ setlength(result,resindex-1);
+ end;
+
+
+const
+ SNoUnicodestrings = 'This binary has no unicodestrings support compiled in.';
+ SRecompileWithUnicodestrings = 'Recompile the application with a unicodestrings-manager in the program uses clause.';
+
+procedure unimplementedunicodestring;
+ begin
+{$ifdef FPC_HAS_FEATURE_CONSOLEIO}
+ If IsConsole then
+ begin
+ Writeln(StdErr,SNoUnicodestrings);
+ Writeln(StdErr,SRecompileWithUnicodestrings);
+ end;
+{$endif FPC_HAS_FEATURE_CONSOLEIO}
+ HandleErrorFrame(233,get_frame);
+ end;
+
+{$warnings off}
+function GenericUnicodeCase(const s : UnicodeString) : UnicodeString;
+ begin
+ unimplementedunicodestring;
+ end;
+
+
+function CompareUnicodeString(const s1, s2 : UnicodeString) : PtrInt;
+ begin
+ unimplementedunicodestring;
+ end;
+
+
+function CompareTextUnicodeString(const s1, s2 : UnicodeString): PtrInt;
+ begin
+ unimplementedunicodestring;
+ end;
+
+
+function CharLengthPChar(const Str: PChar): PtrInt;
+ begin
+ unimplementedunicodestring;
+ end;
+
+{$warnings on}
+
+procedure initunicodestringmanager;
+ begin
+{$ifndef HAS_WIDESTRINGMANAGER}
+ widestringmanager.Unicode2AnsiMoveProc:=@defaultUnicode2AnsiMove;
+ widestringmanager.Ansi2UnicodeMoveProc:=@defaultAnsi2UnicodeMove;
+ widestringmanager.UpperUnicodeStringProc:=@GenericUnicodeCase;
+ widestringmanager.LowerUnicodeStringProc:=@GenericUnicodeCase;
+{$endif HAS_WIDESTRINGMANAGER}
+ widestringmanager.CompareUnicodeStringProc:=@CompareUnicodeString;
+ widestringmanager.CompareTextUnicodeStringProc:=@CompareTextUnicodeString;
+
+{$ifdef FPC_WIDESTRING_EQUAL_UNICODESTRING}
+{$ifndef HAS_WIDESTRINGMANAGER}
+ widestringmanager.Wide2AnsiMoveProc:=@defaultUnicode2AnsiMove;
+ widestringmanager.Ansi2WideMoveProc:=@defaultAnsi2UnicodeMove;
+ widestringmanager.UpperWideStringProc:=@GenericUnicodeCase;
+ widestringmanager.LowerWideStringProc:=@GenericUnicodeCase;
+{$endif HAS_WIDESTRINGMANAGER}
+ widestringmanager.CompareWideStringProc:=@CompareUnicodeString;
+ widestringmanager.CompareTextWideStringProc:=@CompareTextUnicodeString;
+ widestringmanager.CharLengthPCharProc:=@CharLengthPChar;
+{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
+ end;
+
diff --git a/rtl/inc/variant.inc b/rtl/inc/variant.inc
index 70458c5743..6b0b594347 100644
--- a/rtl/inc/variant.inc
+++ b/rtl/inc/variant.inc
@@ -225,25 +225,30 @@ end;
{ Strings }
operator :=(const source : shortstring) dest : variant;{$ifdef SYSTEMINLINE}inline;{$endif}
-
begin
VariantManager.VarFromPStr(Dest,Source);
end;
operator :=(const source : ansistring) dest : variant;{$ifdef SYSTEMINLINE}inline;{$endif}
-
begin
VariantManager.VarFromLStr(Dest,Source);
end;
operator :=(const source : widestring) dest : variant;{$ifdef SYSTEMINLINE}inline;{$endif}
-
begin
VariantManager.VarFromWStr(Dest,Source);
end;
+
+{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
+operator :=(const source : UnicodeString) dest : variant;{$ifdef SYSTEMINLINE}inline;{$endif}
+begin
+ VariantManager.VarFromWStr(Dest,Source);
+end;
+{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
+
{ Floats }
{$ifdef SUPPORT_SINGLE}
@@ -412,23 +417,34 @@ end;
{ Strings }
operator :=(const source : variant) dest : shortstring;{$ifdef SYSTEMINLINE}inline;{$endif}
-
begin
VariantManager.VarToPStr(Dest,Source);
end;
-operator :=(const source : variant) dest : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : variant) dest : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
VariantManager.vartolstr(dest,source);
end;
-operator :=(const source : variant) dest : widestring;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : variant) dest : widestring;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
variantmanager.vartowstr(dest,source);
end;
+
+{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
+operator :=(const source : variant) dest : UnicodeString;{$ifdef SYSTEMINLINE}inline;{$endif}
+var
+ res : WideString;
+begin
+ variantmanager.vartowstr(res,source);
+ dest:=res;
+end;
+{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
+
+
{ Floats }
{$ifdef SUPPORT_SINGLE}
@@ -623,7 +639,7 @@ procedure VarArrayRedim(var A: Variant; HighBound: SizeInt);
procedure VarArrayPut(var A: Variant; const Value: Variant; const Indices: array of SizeInt);
begin
- if Length(Indices)>0 then
+ if Length(Indices)>0 then
variantmanager.vararrayput(A, Value, Length(Indices), @Indices[0])
else
variantmanager.vararrayput(A, Value, 0, nil);
@@ -632,13 +648,13 @@ procedure VarArrayPut(var A: Variant; const Value: Variant; const Indices: array
function VarArrayGet(const A: Variant; const Indices: array of SizeInt): Variant;
begin
- if Length(Indices)>0 then
+ if Length(Indices)>0 then
Result:=variantmanager.vararrayget(A, Length(Indices), @Indices[0])
- else
+ else
Result:=variantmanager.vararrayget(A, 0, nil);
end;
-
-
+
+
procedure VarCast(var dest : variant;const source : variant;vartype : longint);
begin
@@ -763,6 +779,16 @@ operator :=(const source : olevariant) dest : widestring;{$ifdef SYSTEMINLINE}in
end;
+{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
+operator :=(const source : olevariant) dest : UnicodeString;{$ifdef SYSTEMINLINE}inline;{$endif}
+ var
+ res : WideString;
+ begin
+ variantmanager.vartowstr(res,variant(tvardata(source)));
+ dest:=res;
+ end;
+{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
+
{ Floats }
{$ifdef SUPPORT_SINGLE}
operator :=(const source : olevariant) dest : single;{$ifdef SYSTEMINLINE}inline;{$endif}
@@ -931,6 +957,14 @@ operator :=(const source : widestring) dest : olevariant;{$ifdef SYSTEMINLINE}in
end;
+{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
+operator :=(const source : UnicodeString) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ variantmanager.varfromwstr(variant(tvardata(dest)),source);
+ end;
+{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
+
+
{ Floats }
{$ifdef SUPPORT_SINGLE}
operator :=(const source : single) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
@@ -1050,6 +1084,14 @@ Function Pos (w : WideString; Const v : Variant) : SizeInt;{$ifdef SYSTEMINLINE}
end;
+{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
+Function Pos (w : UnicodeString; Const v : Variant) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ Result:=Pos(w,UnicodeString(v));
+ end;
+{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
+
+
Function Pos (v : Variant; Const c : Char) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Result:=Pos(ShortString(v),c);
@@ -1074,6 +1116,14 @@ Function Pos (v : Variant; Const w : WideString) : SizeInt;{$ifdef SYSTEMINLINE}
end;
+{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
+Function Pos (v : Variant; Const w : UnicodeString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ Result:=Pos(UnicodeString(v),w);
+ end;
+{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
+
+
Function Pos (v1 : Variant; Const v2 : Variant) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Result:=Pos(WideString(v1),WideString(v2));
diff --git a/rtl/inc/varianth.inc b/rtl/inc/varianth.inc
index 09b1bda314..09513fbafb 100644
--- a/rtl/inc/varianth.inc
+++ b/rtl/inc/varianth.inc
@@ -243,6 +243,9 @@ operator :=(const source : widechar) dest : variant;{$ifdef SYSTEMINLINE}inline;
operator :=(const source : shortstring) dest : variant;{$ifdef SYSTEMINLINE}inline;{$endif}
operator :=(const source : ansistring) dest : variant;{$ifdef SYSTEMINLINE}inline;{$endif}
operator :=(const source : widestring) dest : variant;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
+operator :=(const source : UnicodeString) dest : variant;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{ Floats }
{$ifdef SUPPORT_SINGLE}
@@ -297,6 +300,9 @@ operator :=(const source : variant) dest : widechar;{$ifdef SYSTEMINLINE}inline;
operator :=(const source : variant) dest : shortstring;{$ifdef SYSTEMINLINE}inline;{$endif}
operator :=(const source : variant) dest : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
operator :=(const source : variant) dest : widestring;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
+operator :=(const source : variant) dest : unicodestring;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{ Floats }
{$ifdef SUPPORT_SINGLE}
@@ -388,6 +394,9 @@ operator :=(const source : olevariant) dest : widechar;{$ifdef SYSTEMINLINE}inli
operator :=(const source : olevariant) dest : shortstring;{$ifdef SYSTEMINLINE}inline;{$endif}
operator :=(const source : olevariant) dest : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
operator :=(const source : olevariant) dest : widestring;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
+operator :=(const source : olevariant) dest : UnicodeString;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{ Floats }
{$ifdef SUPPORT_SINGLE}
@@ -442,6 +451,9 @@ operator :=(const source : widechar) dest : olevariant;{$ifdef SYSTEMINLINE}inli
operator :=(const source : shortstring) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
operator :=(const source : ansistring) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
operator :=(const source : widestring) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
+operator :=(const source : UnicodeString) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{ Floats }
{$ifdef SUPPORT_SINGLE}
@@ -474,10 +486,16 @@ Function Pos (c : Char; Const v : Variant) : SizeInt;{$ifdef SYSTEMINLINE}inline
Function Pos (s : ShortString; Const v : Variant) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
Function Pos (a : AnsiString; Const v : Variant) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
Function Pos (w : WideString; Const v : Variant) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
+Function Pos (w : UnicodeString; Const v : Variant) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
Function Pos (v : Variant; Const c : Char) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
Function Pos (v : Variant; Const s : ShortString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
Function Pos (v : Variant; Const a : AnsiString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
Function Pos (v : Variant; Const w : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
+Function Pos (v : Variant; Const w : UnicodeString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
Function Pos (v1 : Variant; Const v2 : Variant) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
{**********************************************************************
diff --git a/rtl/inc/wstring22h.inc b/rtl/inc/wstring22h.inc
new file mode 100644
index 0000000000..5861197dcf
--- /dev/null
+++ b/rtl/inc/wstring22h.inc
@@ -0,0 +1,108 @@
+{
+ This file is part of the Free Pascal run time library.
+ Copyright (c) 1999-2005 by Florian Klaempfl,
+ member of the Free Pascal development team.
+
+ This file implements support routines for WideStrings with FPC 2.2
+
+ 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 can be removed when the 2.2.x series is outdated }
+
+Procedure UniqueString (Var S : WideString);external name 'FPC_WIDESTR_UNIQUE';
+Function Pos (Const Substr : WideString; Const Source : WideString) : SizeInt;
+Function Pos (c : Char; Const s : WideString) : SizeInt;
+Function Pos (c : WideChar; Const s : WideString) : SizeInt;
+Function Pos (c : WideChar; Const s : AnsiString) : SizeInt;
+Function Pos (c : AnsiString; Const s : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+Function Pos (c : WideString; Const s : AnsiString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+Function Pos (c : ShortString; Const s : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+
+Function UpCase(const s : WideString) : WideString;
+
+Procedure Insert (Const Source : WideString; Var S : WideString; Index : SizeInt);
+Procedure Delete (Var S : WideString; Index,Size: SizeInt);
+Procedure SetString (Out S : WideString; Buf : PWideChar; Len : SizeInt);
+Procedure SetString (Out S : WideString; Buf : PChar; Len : SizeInt);
+
+function WideCharToString(S : PWideChar) : AnsiString;
+function StringToWideChar(const Src : AnsiString;Dest : PWideChar;DestSize : SizeInt) : PWideChar;
+function WideCharLenToString(S : PWideChar;Len : SizeInt) : AnsiString;
+procedure WideCharLenToStrVar(Src : PWideChar;Len : SizeInt;out Dest : AnsiString);
+procedure WideCharToStrVar(S : PWideChar;out Dest : AnsiString);
+
+procedure DefaultWide2AnsiMove(source:pwidechar;var dest:ansistring;len:SizeInt);
+procedure DefaultAnsi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
+
+Type
+ { hooks for internationalization
+ please add new procedures at the end, it makes it easier to detect new procedures }
+ TWideStringManager = record
+ Wide2AnsiMoveProc : procedure(source:pwidechar;var dest:ansistring;len:SizeInt);
+ Ansi2WideMoveProc : procedure(source:pchar;var dest:widestring;len:SizeInt);
+
+// UpperUTF8 : procedure(p:PUTF8String);
+
+ UpperWideStringProc : function(const S: WideString): WideString;
+// UpperUCS4 : procedure(p:PUCS4Char);
+// LowerUTF8 : procedure(p:PUTF8String);
+ LowerWideStringProc : function(const S: WideString): WideString;
+// LowerUCS4 : procedure(p:PUCS4Char);
+{
+ CompUTF8 : function(p1,p2:PUTF8String) : shortint;
+ CompUCS2 : function(p1,p2:PUCS2Char) : shortint;
+ CompUCS4 : function(p1,p2:PUC42Char) : shortint;
+}
+ CompareWideStringProc : function(const s1, s2 : WideString) : PtrInt;
+ CompareTextWideStringProc : function(const s1, s2 : WideString): PtrInt;
+ CharLengthPCharProc : function(const Str: PChar): PtrInt;
+
+ UpperAnsiStringProc : function(const s : ansistring) : ansistring;
+ LowerAnsiStringProc : function(const s : ansistring) : ansistring;
+ CompareStrAnsiStringProc : function(const S1, S2: ansistring): PtrInt;
+ CompareTextAnsiStringProc : function(const S1, S2: ansistring): PtrInt;
+ StrCompAnsiStringProc : function(S1, S2: PChar): PtrInt;
+ StrICompAnsiStringProc : function(S1, S2: PChar): PtrInt;
+ StrLCompAnsiStringProc : function(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
+ StrLICompAnsiStringProc : function(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
+ StrLowerAnsiStringProc : function(Str: PChar): PChar;
+ StrUpperAnsiStringProc : function(Str: PChar): PChar;
+ ThreadInitProc : procedure;
+ ThreadFiniProc : procedure;
+ end;
+ TUnicodeStringManager = TWideStringManager;
+
+function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+function UnicodeToUtf8(Dest: PChar; MaxDestBytes: SizeUInt; Source: PWideChar; SourceChars: SizeUInt): SizeUInt;
+function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: SizeUInt; Source: PChar; SourceBytes: SizeUInt): SizeUInt;
+function UTF8Encode(const s : WideString) : UTF8String;
+function UTF8Decode(const s : UTF8String): WideString;
+function AnsiToUtf8(const s : ansistring): UTF8String;{$ifdef SYSTEMINLINE}inline;{$endif}
+function Utf8ToAnsi(const s : UTF8String) : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
+function WideStringToUCS4String(const s : WideString) : UCS4String;
+function UCS4StringToWideString(const s : UCS4String) : WideString;
+
+{$ifdef MSWINDOWS}
+const
+ winwidestringalloc : boolean = true;
+{$endif MSWINDOWS}
+
+var
+ widestringmanager : TWideStringManager;
+
+Procedure GetWideStringManager (Var Manager : TWideStringManager);
+Procedure SetWideStringManager (Const New : TWideStringManager);
+Procedure SetWideStringManager (Const New : TWideStringManager; Var Old: TWideStringManager);
+
+Procedure GetUnicodeStringManager (Var Manager : TUnicodeStringManager);
+Procedure SetUnicodeStringManager (Const New : TUnicodeStringManager);
+Procedure SetUnicodeStringManager (Const New : TUnicodeStringManager; Var Old: TUnicodeStringManager);
+
diff --git a/rtl/inc/wstringh.inc b/rtl/inc/wstringh.inc
index 1d9f2f23b9..d933fef0c0 100644
--- a/rtl/inc/wstringh.inc
+++ b/rtl/inc/wstringh.inc
@@ -31,73 +31,20 @@ Procedure Delete (Var S : WideString; Index,Size: SizeInt);
Procedure SetString (Out S : WideString; Buf : PWideChar; Len : SizeInt);
Procedure SetString (Out S : WideString; Buf : PChar; Len : SizeInt);
-function WideCharToString(S : PWideChar) : AnsiString;
-function StringToWideChar(const Src : AnsiString;Dest : PWideChar;DestSize : SizeInt) : PWideChar;
-function WideCharLenToString(S : PWideChar;Len : SizeInt) : AnsiString;
-procedure WideCharLenToStrVar(Src : PWideChar;Len : SizeInt;out Dest : AnsiString);
-procedure WideCharToStrVar(S : PWideChar;out Dest : AnsiString);
-
procedure DefaultWide2AnsiMove(source:pwidechar;var dest:ansistring;len:SizeInt);
procedure DefaultAnsi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
-Type
- { hooks for internationalization
- please add new procedures at the end, it makes it easier to detect new procedures }
- TWideStringManager = record
- Wide2AnsiMoveProc : procedure(source:pwidechar;var dest:ansistring;len:SizeInt);
- Ansi2WideMoveProc : procedure(source:pchar;var dest:widestring;len:SizeInt);
-
-// UpperUTF8 : procedure(p:PUTF8String);
-
- UpperWideStringProc : function(const S: WideString): WideString;
-// UpperUCS4 : procedure(p:PUCS4Char);
-// LowerUTF8 : procedure(p:PUTF8String);
- LowerWideStringProc : function(const S: WideString): WideString;
-// LowerUCS4 : procedure(p:PUCS4Char);
-{
- CompUTF8 : function(p1,p2:PUTF8String) : shortint;
- CompUCS2 : function(p1,p2:PUCS2Char) : shortint;
- CompUCS4 : function(p1,p2:PUC42Char) : shortint;
-}
- CompareWideStringProc : function(const s1, s2 : WideString) : PtrInt;
- CompareTextWideStringProc : function(const s1, s2 : WideString): PtrInt;
- CharLengthPCharProc : function(const Str: PChar): PtrInt;
-
- UpperAnsiStringProc : function(const s : ansistring) : ansistring;
- LowerAnsiStringProc : function(const s : ansistring) : ansistring;
- CompareStrAnsiStringProc : function(const S1, S2: ansistring): PtrInt;
- CompareTextAnsiStringProc : function(const S1, S2: ansistring): PtrInt;
- StrCompAnsiStringProc : function(S1, S2: PChar): PtrInt;
- StrICompAnsiStringProc : function(S1, S2: PChar): PtrInt;
- StrLCompAnsiStringProc : function(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
- StrLICompAnsiStringProc : function(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
- StrLowerAnsiStringProc : function(Str: PChar): PChar;
- StrUpperAnsiStringProc : function(Str: PChar): PChar;
- ThreadInitProc : procedure;
- ThreadFiniProc : procedure;
- end;
-
+type
+ TWideStringManager = TUnicodeStringManager;
function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
function UnicodeToUtf8(Dest: PChar; MaxDestBytes: SizeUInt; Source: PWideChar; SourceChars: SizeUInt): SizeUInt;
function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: SizeUInt; Source: PChar; SourceBytes: SizeUInt): SizeUInt;
function UTF8Encode(const s : WideString) : UTF8String;
-function UTF8Decode(const s : UTF8String): WideString;
-function AnsiToUtf8(const s : ansistring): UTF8String;{$ifdef SYSTEMINLINE}inline;{$endif}
-function Utf8ToAnsi(const s : UTF8String) : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
-function WideStringToUCS4String(const s : WideString) : UCS4String;
-function UCS4StringToWideString(const s : UCS4String) : WideString;
{$ifdef MSWINDOWS}
const
winwidestringalloc : boolean = true;
{$endif MSWINDOWS}
-var
- widestringmanager : TWideStringManager;
-
-Procedure GetWideStringManager (Var Manager : TWideStringManager);
-Procedure SetWideStringManager (Const New : TWideStringManager);
-Procedure SetWideStringManager (Const New : TWideStringManager; Var Old: TWideStringManager);
-
diff --git a/rtl/inc/wstrings.inc b/rtl/inc/wstrings.inc
index 65c455e1f2..fc3ec06730 100644
--- a/rtl/inc/wstrings.inc
+++ b/rtl/inc/wstrings.inc
@@ -1,17 +1,1501 @@
-{
- This file is part of the Free Pascal run time library.
- Copyright (c) 1999-2005 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.
-
- **********************************************************************}
-
-{$i wustrings.inc}
+{
+ This file is part of the Free Pascal run time library.
+ Copyright (c) 1999-2005 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 :
+
+ @-8 : SizeInt for reference count;
+ @-4 : SizeInt for size; size=number of bytes, not the number of chars. Divide or multiply
+ with sizeof(WideChar) to convert. This is needed to be compatible with Delphi and
+ Windows COM BSTR.
+ @ : 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
+ Len : DWord;
+ 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 DefaultWide2AnsiMove(source:pwidechar;var dest:ansistring;len:SizeInt);
+var
+ i : SizeInt;
+begin
+ setlength(dest,len);
+ for i:=1 to len do
+ begin
+ if word(source^)<256 then
+ dest[i]:=char(word(source^))
+ else
+ dest[i]:='?';
+ inc(source);
+ end;
+end;
+
+
+procedure DefaultAnsi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
+var
+ i : SizeInt;
+begin
+ setlength(dest,len);
+ for i:=1 to len do
+ begin
+ dest[i]:=widechar(byte(source^));
+ inc(source);
+ end;
+end;
+
+
+(*
+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.
+****************************************************************************}
+
+
+procedure WideStringError;
+ begin
+ HandleErrorFrame(204,get_frame);
+ end;
+
+
+{$ifdef WideStrDebug}
+Procedure DumpWideRec(S : Pointer);
+begin
+ If S=Nil then
+ Writeln ('String is nil')
+ Else
+ Begin
+ With PWideRec(S-WideFirstOff)^ do
+ begin
+ Write ('(Len:',len);
+ Writeln (' Ref: ',ref,')');
+ end;
+ end;
+end;
+{$endif}
+
+
+Function NewWideString(Len : SizeInt) : Pointer;
+{
+ Allocate a new WideString on the heap.
+ initialize it to zero length and reference count 1.
+}
+Var
+ P : Pointer;
+begin
+{$ifdef MSWINDOWS}
+ if winwidestringalloc then
+ begin
+ P:=SysAllocStringLen(nil,Len);
+ if P=nil then
+ WideStringError;
+ end
+ else
+{$endif MSWINDOWS}
+ begin
+ GetMem(P,Len*sizeof(WideChar)+WideRecLen);
+ If P<>Nil then
+ begin
+ PWideRec(P)^.Len:=Len*2; { Initial length }
+ PWideRec(P)^.First:=#0; { Terminating #0 }
+ inc(p,WideFirstOff); { Points to string now }
+ end
+ else
+ WideStringError;
+ end;
+ NewWideString:=P;
+end;
+
+
+Procedure DisposeWideString(Var S : Pointer);
+{
+ Deallocates a WideString From the heap.
+}
+begin
+ If S=Nil then
+ exit;
+{$ifndef MSWINDOWS}
+ Dec (S,WideFirstOff);
+ Freemem(S);
+{$else MSWINDOWS}
+ if winwidestringalloc then
+ SysFreeString(S)
+ else
+ begin
+ Dec (S,WideFirstOff);
+ Freemem(S);
+ end;
+{$endif MSWINDOWS}
+ S:=Nil;
+end;
+
+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;
+
+Procedure fpc_WideStr_Decr_Ref (Var S : Pointer);[Public,Alias:'FPC_WIDESTR_DECR_REF']; compilerproc;
+{
+ Decreases the ReferenceCount of a non constant widestring;
+ If the reference count is zero, deallocate the string;
+}
+Type
+ pSizeInt = ^SizeInt;
+Begin
+ { Zero string }
+ if S=Nil then
+ exit;
+ if not IsWideStringConstant(S) then
+ DisposeWideString(S);
+end;
+
+{ alias for internal use }
+Procedure fpc_WideStr_Decr_Ref (Var S : Pointer);[external name 'FPC_WIDESTR_DECR_REF'];
+
+Procedure fpc_WideStr_Incr_Ref(Var S : Pointer);[Public,Alias:'FPC_WIDESTR_INCR_REF']; compilerproc;
+ var
+ p : pointer;
+ Begin
+ If S=Nil then
+ exit;
+ p:=NewWidestring(length(WideString(S)));
+ move(s^,p^,(length(WideString(s))+1)*sizeof(widechar)); // double #0 too
+ s:=p;
+ end;
+
+{ alias for internal use }
+Procedure fpc_WideStr_Incr_Ref (Var S : Pointer);[external name 'FPC_WIDESTR_INCR_REF'];
+
+{$ifndef FPC_STRTOSHORTSTRINGPROC}
+function fpc_WideStr_To_ShortStr (high_of_res: SizeInt;const S2 : WideString): shortstring;[Public, alias: 'FPC_WIDESTR_TO_SHORTSTR']; compilerproc;
+{
+ Converts a WideString to a ShortString;
+}
+Var
+ Size : SizeInt;
+ temp : ansistring;
+begin
+ result:='';
+ Size:=Length(S2);
+ if Size>0 then
+ begin
+ If Size>high_of_res then
+ Size:=high_of_res;
+ widestringmanager.Wide2AnsiMoveProc(PWideChar(S2),temp,Size);
+ result:=temp;
+ end;
+end;
+{$else FPC_STRTOSHORTSTRINGPROC}
+procedure fpc_WideStr_To_ShortStr (out res: ShortString;const S2 : WideString); [Public, alias: 'FPC_WIDESTR_TO_SHORTSTR'];compilerproc;
+{
+ Converts a WideString to a ShortString;
+}
+Var
+ Size : SizeInt;
+ temp : ansistring;
+begin
+ res:='';
+ Size:=Length(S2);
+ if Size>0 then
+ begin
+ If Size>high(res) then
+ Size:=high(res);
+ widestringmanager.Wide2AnsiMoveProc(PWideChar(S2),temp,Size);
+ res:=temp;
+ end;
+end;
+{$endif FPC_STRTOSHORTSTRINGPROC}
+
+
+Function fpc_ShortStr_To_WideStr (Const S2 : ShortString): WideString;compilerproc;
+{
+ Converts a ShortString to a WideString;
+}
+Var
+ Size : SizeInt;
+begin
+ result:='';
+ Size:=Length(S2);
+ if Size>0 then
+ begin
+ widestringmanager.Ansi2WideMoveProc(PChar(@S2[1]),result,Size);
+ { Terminating Zero }
+ PWideChar(Pointer(fpc_ShortStr_To_WideStr)+Size*sizeof(WideChar))^:=#0;
+ end;
+end;
+
+
+Function fpc_WideStr_To_AnsiStr (const S2 : WideString): AnsiString; compilerproc;
+{
+ Converts a WideString to an AnsiString
+}
+Var
+ Size : SizeInt;
+begin
+ result:='';
+ Size:=Length(S2);
+ if Size>0 then
+ widestringmanager.Wide2AnsiMoveProc(PWideChar(Pointer(S2)),result,Size);
+end;
+
+
+Function fpc_AnsiStr_To_WideStr (Const S2 : AnsiString): WideString; compilerproc;
+{
+ Converts an AnsiString to a WideString;
+}
+Var
+ Size : SizeInt;
+begin
+ result:='';
+ Size:=Length(S2);
+ if Size>0 then
+ widestringmanager.Ansi2WideMoveProc(PChar(S2),result,Size);
+end;
+
+
+Function fpc_PWideChar_To_WideStr(const p : pwidechar): widestring; compilerproc;
+var
+ Size : SizeInt;
+begin
+ result:='';
+ if p=nil then
+ exit;
+ Size := IndexWord(p^, -1, 0);
+ Setlength(result,Size);
+ if Size>0 then
+ begin
+ Move(p^,PWideChar(Pointer(result))^,Size*sizeof(WideChar));
+ { Terminating Zero }
+ PWideChar(Pointer(result)+Size*sizeof(WideChar))^:=#0;
+ 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']; compilerproc;
+{
+ Assigns S2 to S1 (S1:=S2), taking in account reference counts.
+}
+begin
+ if S1=S2 then exit;
+ if S2<>nil then
+ begin
+ 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
+ begin
+ { Free S1 }
+ fpc_widestr_decr_ref (S1);
+ S1:=nil;
+ end;
+end;
+
+
+{ alias for internal use }
+Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[external name 'FPC_WIDESTR_ASSIGN'];
+
+{$ifndef STR_CONCAT_PROCS}
+
+function fpc_WideStr_Concat (const S1,S2 : WideString): WideString; compilerproc;
+Var
+ Size,Location : SizeInt;
+ pc : pwidechar;
+begin
+ { only assign if s1 or s2 is empty }
+ if (S1='') then
+ begin
+ result:=s2;
+ exit;
+ end;
+ if (S2='') then
+ begin
+ result:=s1;
+ exit;
+ end;
+ Location:=Length(S1);
+ Size:=length(S2);
+ SetLength(result,Size+Location);
+ pc:=pwidechar(result);
+ Move(S1[1],pc^,Location*sizeof(WideChar));
+ inc(pc,location);
+ Move(S2[1],pc^,(Size+1)*sizeof(WideChar));
+end;
+
+
+function fpc_WideStr_Concat_multi (const sarr:array of Widestring): widestring; compilerproc;
+Var
+ i : Longint;
+ p : pointer;
+ pc : pwidechar;
+ Size,NewSize : SizeInt;
+begin
+ { First calculate size of the result so we can do
+ a single call to SetLength() }
+ NewSize:=0;
+ for i:=low(sarr) to high(sarr) do
+ inc(Newsize,length(sarr[i]));
+ SetLength(result,NewSize);
+ pc:=pwidechar(result);
+ for i:=low(sarr) to high(sarr) do
+ begin
+ p:=pointer(sarr[i]);
+ if assigned(p) then
+ begin
+ Size:=length(widestring(p));
+ Move(pwidechar(p)^,pc^,(Size+1)*sizeof(WideChar));
+ inc(pc,size);
+ end;
+ end;
+end;
+
+{$else STR_CONCAT_PROCS}
+
+procedure fpc_WideStr_Concat (var DestS:Widestring;const S1,S2 : WideString); compilerproc;
+Var
+ Size,Location : SizeInt;
+ same : boolean;
+begin
+ { only assign if s1 or s2 is empty }
+ if (S1='') then
+ begin
+ DestS:=s2;
+ exit;
+ end;
+ if (S2='') then
+ begin
+ DestS:=s1;
+ exit;
+ end;
+ Location:=Length(S1);
+ Size:=length(S2);
+ { Use Pointer() typecasts to prevent extra conversion code }
+ if Pointer(DestS)=Pointer(S1) then
+ begin
+ same:=Pointer(S1)=Pointer(S2);
+ SetLength(DestS,Size+Location);
+ if same then
+ Move(Pointer(DestS)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size)*sizeof(WideChar))
+ else
+ Move(Pointer(S2)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
+ end
+ else if Pointer(DestS)=Pointer(S2) then
+ begin
+ SetLength(DestS,Size+Location);
+ Move(Pointer(DestS)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
+ Move(Pointer(S1)^,Pointer(DestS)^,Location*sizeof(WideChar));
+ end
+ else
+ begin
+ DestS:='';
+ SetLength(DestS,Size+Location);
+ Move(Pointer(S1)^,Pointer(DestS)^,Location*sizeof(WideChar));
+ Move(Pointer(S2)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
+ end;
+end;
+
+
+procedure fpc_WideStr_Concat_multi (var DestS:Widestring;const sarr:array of Widestring); compilerproc;
+Var
+ i : Longint;
+ p,pc : pointer;
+ Size,NewLen : SizeInt;
+ DestTmp : Widestring;
+begin
+ if high(sarr)=0 then
+ begin
+ DestS:='';
+ exit;
+ end;
+ { First calculate size of the result so we can do
+ a single call to SetLength() }
+ NewLen:=0;
+ for i:=low(sarr) to high(sarr) do
+ inc(NewLen,length(sarr[i]));
+ SetLength(DestTmp,NewLen);
+ pc:=pwidechar(DestTmp);
+ for i:=low(sarr) to high(sarr) do
+ begin
+ p:=pointer(sarr[i]);
+ if assigned(p) then
+ begin
+ Size:=length(widestring(p));
+ Move(p^,pc^,(Size+1)*sizeof(WideChar));
+ inc(pc,size*sizeof(WideChar));
+ end;
+ end;
+ DestS:=DestTmp;
+end;
+
+{$endif STR_CONCAT_PROCS}
+
+
+Function fpc_Char_To_WideStr(const c : Char): WideString; compilerproc;
+{
+ Converts a Char to a WideString;
+}
+begin
+ Setlength(fpc_Char_To_WideStr,1);
+ fpc_Char_To_WideStr[1]:=c;
+ { Terminating Zero }
+ PWideChar(Pointer(fpc_Char_To_WideStr)+sizeof(WideChar))^:=#0;
+end;
+
+
+Function fpc_WChar_To_WideStr(const c : WideChar): WideString; compilerproc;
+{
+ Converts a WideChar to a WideString;
+}
+begin
+ Setlength (fpc_WChar_To_WideStr,1);
+ fpc_WChar_To_WideStr[1]:= c;
+end;
+
+
+Function fpc_WChar_To_AnsiStr(const c : WideChar): AnsiString; compilerproc;
+{
+ Converts a WideChar to a AnsiString;
+}
+begin
+ widestringmanager.Wide2AnsiMoveProc(@c, fpc_WChar_To_AnsiStr, 1);
+end;
+
+
+Function fpc_UChar_To_WideStr(const c : WideChar): WideString; compilerproc;
+{
+ Converts a WideChar to a WideString;
+}
+begin
+ Setlength (fpc_UChar_To_WideStr,1);
+ fpc_UChar_To_WideStr[1]:= c;
+end;
+
+
+Function fpc_PChar_To_WideStr(const p : pchar): WideString; compilerproc;
+Var
+ L : SizeInt;
+begin
+ if (not assigned(p)) or (p[0]=#0) Then
+ begin
+ fpc_pchar_to_widestr := '';
+ exit;
+ end;
+ l:=IndexChar(p^,-1,#0);
+ widestringmanager.Ansi2WideMoveProc(P,fpc_PChar_To_WideStr,l);
+end;
+
+
+Function fpc_CharArray_To_WideStr(const arr: array of char; zerobased: boolean = true): WideString; compilerproc;
+var
+ i : SizeInt;
+begin
+ if (zerobased) then
+ begin
+ if (arr[0]=#0) Then
+ begin
+ fpc_chararray_to_widestr := '';
+ exit;
+ end;
+ i:=IndexChar(arr,high(arr)+1,#0);
+ if i = -1 then
+ i := high(arr)+1;
+ end
+ else
+ i := high(arr)+1;
+ SetLength(fpc_CharArray_To_WideStr,i);
+ widestringmanager.Ansi2WideMoveProc (pchar(@arr),fpc_CharArray_To_WideStr,i);
+end;
+
+
+{$ifndef FPC_STRTOCHARARRAYPROC}
+
+{ inside the compiler, the resulttype is modified to that of the actual }
+{ chararray we're converting to (JM) }
+function fpc_widestr_to_chararray(arraysize: SizeInt; const src: WideString): fpc_big_chararray;[public,alias: 'FPC_WIDESTR_TO_CHARARRAY']; compilerproc;
+var
+ len: SizeInt;
+ temp: ansistring;
+begin
+ len := length(src);
+ { make sure we don't dereference src if it can be nil (JM) }
+ if len > 0 then
+ widestringmanager.wide2ansimoveproc(pwidechar(@src[1]),temp,len);
+ len := length(temp);
+ if len > arraysize then
+ len := arraysize;
+{$r-}
+ move(temp[1],fpc_widestr_to_chararray[0],len);
+ fillchar(fpc_widestr_to_chararray[len],arraysize-len,0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+
+{ inside the compiler, the resulttype is modified to that of the actual }
+{ widechararray we're converting to (JM) }
+function fpc_widestr_to_widechararray(arraysize: SizeInt; const src: WideString): fpc_big_widechararray;[public,alias: 'FPC_WIDESTR_TO_WIDECHARARRAY']; compilerproc;
+var
+ len: SizeInt;
+begin
+ len := length(src);
+ if len > arraysize then
+ len := arraysize;
+{$r-}
+ { make sure we don't try to access element 1 of the ansistring if it's nil }
+ if len > 0 then
+ move(src[1],fpc_widestr_to_widechararray[0],len*SizeOf(WideChar));
+ fillchar(fpc_widestr_to_widechararray[len],(arraysize-len)*SizeOf(WideChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+
+{ inside the compiler, the resulttype is modified to that of the actual }
+{ chararray we're converting to (JM) }
+function fpc_ansistr_to_widechararray(arraysize: SizeInt; const src: AnsiString): fpc_big_widechararray;[public,alias: 'FPC_ANSISTR_TO_WIDECHARARRAY']; compilerproc;
+var
+ len: SizeInt;
+ temp: widestring;
+begin
+ len := length(src);
+ { make sure we don't dereference src if it can be nil (JM) }
+ if len > 0 then
+ widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
+ len := length(temp);
+ if len > arraysize then
+ len := arraysize;
+
+{$r-}
+ move(temp[1],fpc_ansistr_to_widechararray[0],len*sizeof(widechar));
+ fillchar(fpc_ansistr_to_widechararray[len],(arraysize-len)*SizeOf(WideChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+function fpc_shortstr_to_widechararray(arraysize: SizeInt; const src: ShortString): fpc_big_widechararray;[public,alias: 'FPC_SHORTSTR_TO_WIDECHARARRAY']; compilerproc;
+var
+ len: longint;
+ temp : widestring;
+begin
+ len := length(src);
+ { make sure we don't access char 1 if length is 0 (JM) }
+ if len > 0 then
+ widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
+ len := length(temp);
+ if len > arraysize then
+ len := arraysize;
+{$r-}
+ move(temp[1],fpc_shortstr_to_widechararray[0],len*sizeof(widechar));
+ fillchar(fpc_shortstr_to_widechararray[len],(arraysize-len)*SizeOf(WideChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+{$else ndef FPC_STRTOCHARARRAYPROC}
+
+procedure fpc_widestr_to_chararray(out res: array of char; const src: WideString); compilerproc;
+var
+ len: SizeInt;
+ temp: ansistring;
+begin
+ len := length(src);
+ { make sure we don't dereference src if it can be nil (JM) }
+ if len > 0 then
+ widestringmanager.wide2ansimoveproc(pwidechar(@src[1]),temp,len);
+ len := length(temp);
+ if len > length(res) then
+ len := length(res);
+{$r-}
+ move(temp[1],res[0],len);
+ fillchar(res[len],length(res)-len,0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+
+procedure fpc_widestr_to_widechararray(out res: array of widechar; const src: WideString); compilerproc;
+var
+ len: SizeInt;
+begin
+ len := length(src);
+ if len > length(res) then
+ len := length(res);
+{$r-}
+ { make sure we don't try to access element 1 of the ansistring if it's nil }
+ if len > 0 then
+ move(src[1],res[0],len*SizeOf(WideChar));
+ fillchar(res[len],(length(res)-len)*SizeOf(WideChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+
+{$endif ndef FPC_STRTOCHARARRAYPROC}
+
+Function fpc_WideStr_Compare(const S1,S2 : WideString): SizeInt;[Public,Alias : 'FPC_WIDESTR_COMPARE']; compilerproc;
+{
+ Compares 2 WideStrings;
+ The result is
+ <0 if S1<S2
+ 0 if S1=S2
+ >0 if S1>S2
+}
+Var
+ MaxI,Temp : SizeInt;
+begin
+ if pointer(S1)=pointer(S2) then
+ begin
+ fpc_WideStr_Compare:=0;
+ exit;
+ end;
+ Maxi:=Length(S1);
+ temp:=Length(S2);
+ If MaxI>Temp then
+ MaxI:=Temp;
+ Temp:=CompareWord(S1[1],S2[1],MaxI);
+ if temp=0 then
+ temp:=Length(S1)-Length(S2);
+ fpc_WideStr_Compare:=Temp;
+end;
+
+Function fpc_WideStr_Compare_Equal(const S1,S2 : WideString): SizeInt;[Public,Alias : 'FPC_WIDESTR_COMPARE_EQUAL']; compilerproc;
+{
+ Compares 2 WideStrings for equality only;
+ The result is
+ 0 if S1=S2
+ <>0 if S1<>S2
+}
+Var
+ MaxI : SizeInt;
+begin
+ if pointer(S1)=pointer(S2) then
+ exit(0);
+ Maxi:=Length(S1);
+ If MaxI<>Length(S2) then
+ exit(-1)
+ else
+ exit(CompareWord(S1[1],S2[1],MaxI));
+end;
+
+Procedure fpc_WideStr_CheckZero(p : pointer);[Public,Alias : 'FPC_WIDESTR_CHECKZERO']; compilerproc;
+begin
+ if p=nil then
+ HandleErrorFrame(201,get_frame);
+end;
+
+
+Procedure fpc_WideStr_CheckRange(len,index : SizeInt);[Public,Alias : 'FPC_WIDESTR_RANGECHECK']; compilerproc;
+begin
+ if (index>len div 2) or (Index<1) then
+ HandleErrorFrame(201,get_frame);
+end;
+
+Procedure fpc_WideStr_SetLength(Var S : WideString; l : SizeInt);[Public,Alias : 'FPC_WIDESTR_SETLENGTH']; compilerproc;
+{
+ Sets The length of string S to L.
+ Makes sure S is unique, and contains enough room.
+}
+Var
+ Temp : Pointer;
+ movelen: SizeInt;
+begin
+ if (l>0) then
+ begin
+ if Pointer(S)=nil then
+ begin
+ { Need a complete new string...}
+ Pointer(s):=NewWideString(l);
+ end
+ { windows doesn't support reallocing widestrings, this code
+ is anyways subject to be removed because widestrings shouldn't be
+ ref. counted anymore (FK) }
+ else
+ if
+{$ifdef MSWINDOWS}
+ not winwidestringalloc and
+{$endif MSWINDOWS}
+ not IsWideStringConstant(pointer(S))
+ then
+ begin
+ Dec(Pointer(S),WideFirstOff);
+ if SizeUInt(L*sizeof(WideChar)+WideRecLen)>MemSize(Pointer(S)) then
+ reallocmem(pointer(S), L*sizeof(WideChar)+WideRecLen);
+ Inc(Pointer(S), WideFirstOff);
+ end
+ else
+ begin
+ { Reallocation is needed... }
+ Temp:=Pointer(NewWideString(L));
+ if Length(S)>0 then
+ begin
+ if l < succ(length(s)) then
+ movelen := l
+ { also move terminating null }
+ else
+ movelen := succ(length(s));
+ Move(Pointer(S)^,Temp^,movelen * Sizeof(WideChar));
+ end;
+ fpc_widestr_decr_ref(Pointer(S));
+ Pointer(S):=Temp;
+ end;
+ { Force nil termination in case it gets shorter }
+ PWord(Pointer(S)+l*sizeof(WideChar))^:=0;
+{$ifdef MSWINDOWS}
+ if not winwidestringalloc then
+{$endif MSWINDOWS}
+ PWideRec(Pointer(S)-WideFirstOff)^.Len:=l*sizeof(WideChar);
+ 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.
+*****************************************************************************}
+
+Function fpc_widestr_Unique(Var S : Pointer): Pointer; [Public,Alias : 'FPC_WIDESTR_UNIQUE']; compilerproc;
+ begin
+ pointer(result) := pointer(s);
+ end;
+
+
+Function Fpc_WideStr_Copy (Const S : WideString; Index,Size : SizeInt) : WideString;compilerproc;
+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*sizeof(WideChar);
+ PWideChar(ResultAddress+Size*sizeof(WideChar))^:=#0;
+ end;
+ end;
+ fpc_widestr_decr_ref(Pointer(fpc_widestr_copy));
+ Pointer(fpc_widestr_Copy):=ResultAddress;
+end;
+
+
+Function Pos (Const Substr : WideString; Const Source : WideString) : SizeInt;
+var
+ i,MaxLen : SizeInt;
+ 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) : SizeInt;
+var
+ i: SizeInt;
+ 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;
+
+
+Function Pos (c : WideChar; Const s : AnsiString) : SizeInt;
+ begin
+ result:=Pos(c,WideString(s));
+ end;
+
+
+Function Pos (c : AnsiString; Const s : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ result:=Pos(WideString(c),s);
+ end;
+
+
+Function Pos (c : ShortString; Const s : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ result:=Pos(WideString(c),s);
+ end;
+
+
+Function Pos (c : WideString; Const s : AnsiString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ result:=Pos(c,WideString(s));
+ 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) : SizeInt;
+var
+ i: SizeInt;
+ 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: SizeInt);
+Var
+ LS : SizeInt;
+begin
+ If Length(S)=0 then
+ exit;
+ if index<=0 then
+ exit;
+ LS:=PWideRec(Pointer(S)-WideFirstOff)^.Len div sizeof(WideChar);
+ 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-Size+1)*sizeof(WideChar));
+ end;
+ Setlength(s,LS-Size);
+ end;
+end;
+
+
+Procedure Insert (Const Source : WideString; Var S : WideString; Index : SizeInt);
+var
+ Temp : WideString;
+ LS : SizeInt;
+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;
+
+
+function UpCase(const s : WideString) : WideString;
+begin
+ result:=widestringmanager.UpperWideStringProc(s);
+end;
+
+
+Procedure SetString (Out S : WideString; Buf : PWideChar; Len : SizeInt);
+var
+ BufLen: SizeInt;
+begin
+ SetLength(S,Len);
+ If (Buf<>Nil) and (Len>0) then
+ begin
+ BufLen := IndexWord(Buf^, Len+1, 0);
+ If (BufLen>0) and (BufLen < Len) then
+ Len := BufLen;
+ Move (Buf[0],S[1],Len*sizeof(WideChar));
+ PWideChar(Pointer(S)+Len*sizeof(WideChar))^:=#0;
+ end;
+end;
+
+
+Procedure SetString (Out S : WideString; Buf : PChar; Len : SizeInt);
+var
+ BufLen: SizeInt;
+begin
+ SetLength(S,Len);
+ If (Buf<>Nil) and (Len>0) then
+ begin
+ BufLen := IndexByte(Buf^, Len+1, 0);
+ If (BufLen>0) and (BufLen < Len) then
+ Len := BufLen;
+ widestringmanager.Ansi2WideMoveProc(Buf,S,Len);
+ //PWideChar(Pointer(S)+Len*sizeof(WideChar))^:=#0;
+ end;
+end;
+
+
+{$ifndef FPUNONE}
+Function fpc_Val_Real_WideStr(Const S : WideString; out Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_WIDESTR']; compilerproc;
+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;
+{$endif}
+
+function fpc_val_enum_widestr(str2ordindex:pointer;const s:widestring;out code:valsint):longint;compilerproc;
+
+var ss:shortstring;
+
+begin
+ if length(s)>255 then
+ code:=256
+ else
+ begin
+ ss:=s;
+ val(ss,fpc_val_enum_widestr,code);
+ end;
+end;
+
+Function fpc_Val_Currency_WideStr(Const S : WideString; out Code : ValSInt): Currency; [public, alias:'FPC_VAL_CURRENCY_WIDESTR']; compilerproc;
+Var
+ SS : String;
+begin
+ if length(S) > 255 then
+ begin
+ fpc_Val_Currency_WideStr:=0;
+ code := 256;
+ end
+ else
+ begin
+ SS := S;
+ Val(SS,fpc_Val_Currency_WideStr,code);
+ end;
+end;
+
+
+Function fpc_Val_UInt_WideStr (Const S : WideString; out Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_WIDESTR']; compilerproc;
+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: SizeInt; Const S : WideString; out Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_WIDESTR']; compilerproc;
+Var
+ SS : ShortString;
+begin
+ fpc_Val_SInt_WideStr:=0;
+ if length(S)>255 then
+ code:=256
+ else
+ begin
+ SS := S;
+ fpc_Val_SInt_WideStr := int_Val_SInt_ShortStr(DestSize,SS,Code);
+ end;
+end;
+
+
+{$ifndef CPU64}
+
+Function fpc_Val_qword_WideStr (Const S : WideString; out Code : ValSInt): qword; [public, alias:'FPC_VAL_QWORD_WIDESTR']; compilerproc;
+Var
+ SS : ShortString;
+begin
+ fpc_Val_qword_WideStr:=0;
+ if length(S)>255 then
+ code:=256
+ else
+ begin
+ SS := S;
+ Val(SS,fpc_Val_qword_WideStr,Code);
+ end;
+end;
+
+
+Function fpc_Val_int64_WideStr (Const S : WideString; out Code : ValSInt): Int64; [public, alias:'FPC_VAL_INT64_WIDESTR']; compilerproc;
+Var
+ SS : ShortString;
+begin
+ fpc_Val_int64_WideStr:=0;
+ if length(S)>255 then
+ code:=256
+ else
+ begin
+ SS := S;
+ Val(SS,fpc_Val_int64_WideStr,Code);
+ end;
+end;
+
+{$endif CPU64}
+
+
+{$ifndef FPUNONE}
+procedure fpc_WideStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : WideString);compilerproc;
+var
+ ss : shortstring;
+begin
+ str_real(len,fr,d,treal_type(rt),ss);
+ s:=ss;
+end;
+{$endif}
+
+procedure fpc_widestr_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:widestring);compilerproc;
+
+var ss:shortstring;
+
+begin
+ fpc_shortstr_enum(ordinal,len,typinfo,ord2strindex,ss);
+ s:=ss;
+end;
+
+{$ifdef FPC_HAS_STR_CURRENCY}
+procedure fpc_WideStr_Currency(c : Currency;len,fr : SizeInt;out s : WideString);compilerproc;
+var
+ ss : shortstring;
+begin
+ str(c:len:fr,ss);
+ s:=ss;
+end;
+{$endif FPC_HAS_STR_CURRENCY}
+
+Procedure fpc_WideStr_SInt(v : ValSint; Len : SizeInt; out S : WideString);compilerproc;
+Var
+ SS : ShortString;
+begin
+ Str (v:Len,SS);
+ S:=SS;
+end;
+
+
+Procedure fpc_WideStr_UInt(v : ValUInt;Len : SizeInt; out S : WideString);compilerproc;
+Var
+ SS : ShortString;
+begin
+ str(v:Len,SS);
+ S:=SS;
+end;
+
+
+{$ifndef CPU64}
+
+Procedure fpc_WideStr_Int64(v : Int64; Len : SizeInt; out S : WideString);compilerproc;
+Var
+ SS : ShortString;
+begin
+ Str (v:Len,SS);
+ S:=SS;
+end;
+
+
+Procedure fpc_WideStr_Qword(v : Qword;Len : SizeInt; out S : WideString);compilerproc;
+Var
+ SS : ShortString;
+begin
+ str(v:Len,SS);
+ S:=SS;
+end;
+
+{$endif CPU64}
+
+function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ if assigned(Source) then
+ Result:=UnicodeToUtf8(Dest,MaxBytes,Source,IndexWord(Source^,-1,0))
+ else
+ Result:=0;
+ end;
+
+
+function UnicodeToUtf8(Dest: PChar; MaxDestBytes: SizeUInt; Source: PWideChar; SourceChars: SizeUInt): SizeUInt;
+ var
+ i,j : SizeUInt;
+ w : word;
+ begin
+ result:=0;
+ if source=nil then
+ exit;
+ i:=0;
+ j:=0;
+ if assigned(Dest) then
+ begin
+ while (i<SourceChars) and (j<MaxDestBytes) do
+ begin
+ w:=word(Source[i]);
+ case w of
+ 0..$7f:
+ begin
+ Dest[j]:=char(w);
+ inc(j);
+ end;
+ $80..$7ff:
+ begin
+ if j+1>=MaxDestBytes then
+ break;
+ Dest[j]:=char($c0 or (w shr 6));
+ Dest[j+1]:=char($80 or (w and $3f));
+ inc(j,2);
+ end;
+ else
+ begin
+ if j+2>=MaxDestBytes then
+ break;
+ Dest[j]:=char($e0 or (w shr 12));
+ Dest[j+1]:=char($80 or ((w shr 6)and $3f));
+ Dest[j+2]:=char($80 or (w and $3f));
+ inc(j,3);
+ end;
+ end;
+ inc(i);
+ end;
+
+ if j>SizeUInt(MaxDestBytes-1) then
+ j:=MaxDestBytes-1;
+
+ Dest[j]:=#0;
+ end
+ else
+ begin
+ while i<SourceChars do
+ begin
+ case word(Source[i]) of
+ $0..$7f:
+ inc(j);
+ $80..$7ff:
+ inc(j,2);
+ else
+ inc(j,3);
+ end;
+ inc(i);
+ end;
+ end;
+ result:=j+1;
+ end;
+
+
+function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ if assigned(Source) then
+ Result:=Utf8ToUnicode(Dest,MaxChars,Source,strlen(Source))
+ else
+ Result:=0;
+ end;
+
+
+function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: SizeUInt; Source: PChar; SourceBytes: SizeUInt): SizeUInt;
+
+var
+ i,j : SizeUInt;
+ w: SizeUInt;
+ b : byte;
+begin
+ if not assigned(Source) then
+ begin
+ result:=0;
+ exit;
+ end;
+ result:=SizeUInt(-1);
+ i:=0;
+ j:=0;
+ if assigned(Dest) then
+ begin
+ while (j<MaxDestChars) and (i<SourceBytes) do
+ begin
+ b:=byte(Source[i]);
+ w:=b;
+ inc(i);
+ // 2 or 3 bytes?
+ if b>=$80 then
+ begin
+ w:=b and $3f;
+ if i>=SourceBytes then
+ exit;
+ // 3 bytes?
+ if (b and $20)<>0 then
+ begin
+ b:=byte(Source[i]);
+ inc(i);
+ if i>=SourceBytes then
+ exit;
+ if (b and $c0)<>$80 then
+ exit;
+ w:=(w shl 6) or (b and $3f);
+ end;
+ b:=byte(Source[i]);
+ w:=(w shl 6) or (b and $3f);
+ if (b and $c0)<>$80 then
+ exit;
+ inc(i);
+ end;
+ Dest[j]:=WideChar(w);
+ inc(j);
+ end;
+ if j>=MaxDestChars then j:=MaxDestChars-1;
+ Dest[j]:=#0;
+ end
+ else
+ begin
+ while i<SourceBytes do
+ begin
+ b:=byte(Source[i]);
+ inc(i);
+ // 2 or 3 bytes?
+ if b>=$80 then
+ begin
+ if i>=SourceBytes then
+ exit;
+ // 3 bytes?
+ b := b and $3f;
+ if (b and $20)<>0 then
+ begin
+ b:=byte(Source[i]);
+ inc(i);
+ if i>=SourceBytes then
+ exit;
+ if (b and $c0)<>$80 then
+ exit;
+ end;
+ if (byte(Source[i]) and $c0)<>$80 then
+ exit;
+ inc(i);
+ end;
+ inc(j);
+ end;
+ end;
+ result:=j+1;
+end;
+
+
+function UTF8Encode(const s : WideString) : UTF8String;
+ var
+ i : SizeInt;
+ hs : UTF8String;
+ begin
+ result:='';
+ if s='' then
+ exit;
+ SetLength(hs,length(s)*3);
+ i:=UnicodeToUtf8(pchar(hs),length(hs)+1,PWideChar(s),length(s));
+ if i>0 then
+ begin
+ SetLength(hs,i-1);
+ result:=hs;
+ end;
+ end;
+
+
+{ converts an utf-16 code point or surrogate pair to utf-32 }
+function utf16toutf32(const S: WideString; const index: SizeInt; out len: longint): UCS4Char; [public, alias: 'FPC_WIDETOUTF32'];
+var
+ w: widechar;
+begin
+ { UTF-16 points in the range #$0-#$D7FF and #$E000-#$FFFF }
+ { are the same in UTF-32 }
+ w:=s[index];
+ if (w<=#$d7ff) or
+ (w>=#$e000) then
+ begin
+ result:=UCS4Char(w);
+ len:=1;
+ end
+ { valid surrogate pair? }
+ else if (w<=#$dbff) and
+ { w>=#$d7ff check not needed, checked above }
+ (index<length(s)) and
+ (s[index+1]>=#$dc00) and
+ (s[index+1]<=#$dfff) then
+ { convert the surrogate pair to UTF-32 }
+ begin
+ result:=(UCS4Char(w)-$d800) shl 10 + (UCS4Char(s[index+1])-$dc00) + $10000;
+ len:=2;
+ end
+ else
+ { invalid surrogate -> do nothing }
+ begin
+ result:=UCS4Char(w);
+ len:=1;
+ end;
+end;
+
+
+const
+ SNoWidestrings = 'This binary has no widestrings support compiled in.';
+ SRecompileWithWidestrings = 'Recompile the application with a widestrings-manager in the program uses clause.';
+
+procedure unimplementedwidestring;
+ begin
+{$ifdef FPC_HAS_FEATURE_CONSOLEIO}
+ If IsConsole then
+ begin
+ Writeln(StdErr,SNoWidestrings);
+ Writeln(StdErr,SRecompileWithWidestrings);
+ end;
+{$endif FPC_HAS_FEATURE_CONSOLEIO}
+ HandleErrorFrame(233,get_frame);
+ end;
+
+{$warnings off}
+function GenericWideCase(const s : WideString) : WideString;
+ begin
+ unimplementedwidestring;
+ end;
+
+
+function CompareWideString(const s1, s2 : WideString) : PtrInt;
+ begin
+ unimplementedwidestring;
+ end;
+
+
+function CompareTextWideString(const s1, s2 : WideString): PtrInt;
+ begin
+ unimplementedwidestring;
+ end;
+
+{$warnings on}
+
+function CharLengthPChar(const Str: PChar): PtrInt;forward;
+
+
+procedure initwidestringmanager;
+ begin
+ fillchar(widestringmanager,sizeof(widestringmanager),0);
+{$ifndef HAS_WIDESTRINGMANAGER}
+ widestringmanager.Wide2AnsiMoveProc:=@defaultWide2AnsiMove;
+ widestringmanager.Ansi2WideMoveProc:=@defaultAnsi2WideMove;
+ widestringmanager.UpperWideStringProc:=@GenericWideCase;
+ widestringmanager.LowerWideStringProc:=@GenericWideCase;
+{$endif HAS_WIDESTRINGMANAGER}
+ widestringmanager.CompareWideStringProc:=@CompareWideString;
+ widestringmanager.CompareTextWideStringProc:=@CompareTextWideString;
+ widestringmanager.CharLengthPCharProc:=@CharLengthPChar;
+ end;
diff --git a/rtl/inc/wustring22.inc b/rtl/inc/wustring22.inc
new file mode 100644
index 0000000000..3f79a7d7dd
--- /dev/null
+++ b/rtl/inc/wustring22.inc
@@ -0,0 +1,2021 @@
+{
+ This file is part of the Free Pascal run time library.
+ Copyright (c) 1999-2005 by Florian Klaempfl,
+ member of the Free Pascal development team.
+
+ This file implements support routines for WideStrings/Unicode 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 :
+
+ @-8 : SizeInt for reference count;
+ @-4 : SizeInt for size; size=number of bytes, not the number of chars. Divide or multiply
+ with sizeof(WideChar) to convert. This is needed to be compatible with Delphi and
+ Windows COM BSTR.
+ @ : 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
+{$ifdef FPC_WINLIKEWIDESTRING}
+ Len : DWord;
+{$else FPC_WINLIKEWIDESTRING}
+ Ref : SizeInt;
+ Len : SizeInt;
+{$endif FPC_WINLIKEWIDESTRING}
+ 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 DefaultWide2AnsiMove(source:pwidechar;var dest:ansistring;len:SizeInt);
+var
+ i : SizeInt;
+begin
+ setlength(dest,len);
+ for i:=1 to len do
+ begin
+ if word(source^)<256 then
+ dest[i]:=char(word(source^))
+ else
+ dest[i]:='?';
+ inc(source);
+ end;
+end;
+
+
+procedure DefaultAnsi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
+var
+ i : SizeInt;
+begin
+ setlength(dest,len);
+ for i:=1 to len do
+ begin
+ dest[i]:=widechar(byte(source^));
+ inc(source);
+ end;
+end;
+
+
+Procedure GetUnicodeStringManager (Var Manager : TUnicodeStringManager);
+begin
+ manager:=widestringmanager;
+end;
+
+
+Procedure SetUnicodeStringManager (Const New : TUnicodeStringManager; Var Old: TUnicodeStringManager);
+begin
+ Old:=widestringmanager;
+ widestringmanager:=New;
+end;
+
+
+Procedure SetUnicodeStringManager (Const New : TUnicodeStringManager);
+begin
+ widestringmanager:=New;
+end;
+
+
+Procedure GetWideStringManager (Var Manager : TWideStringManager);
+begin
+ manager:=widestringmanager;
+end;
+
+
+Procedure SetWideStringManager (Const New : TWideStringManager; Var Old: TWideStringManager);
+begin
+ Old:=widestringmanager;
+ widestringmanager:=New;
+end;
+
+
+Procedure SetWideStringManager (Const New : TWideStringManager);
+begin
+ widestringmanager:=New;
+end;
+
+(*
+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.
+****************************************************************************}
+
+
+procedure WideStringError;
+ begin
+ HandleErrorFrame(204,get_frame);
+ end;
+
+
+{$ifdef WideStrDebug}
+Procedure DumpWideRec(S : Pointer);
+begin
+ If S=Nil then
+ Writeln ('String is nil')
+ Else
+ Begin
+ With PWideRec(S-WideFirstOff)^ do
+ begin
+ Write ('(Len:',len);
+ Writeln (' Ref: ',ref,')');
+ end;
+ end;
+end;
+{$endif}
+
+
+Function NewWideString(Len : SizeInt) : Pointer;
+{
+ Allocate a new WideString on the heap.
+ initialize it to zero length and reference count 1.
+}
+Var
+ P : Pointer;
+begin
+{$ifdef MSWINDOWS}
+ if winwidestringalloc then
+ begin
+ P:=SysAllocStringLen(nil,Len);
+ if P=nil then
+ WideStringError;
+ end
+ else
+{$endif MSWINDOWS}
+ begin
+ GetMem(P,Len*sizeof(WideChar)+WideRecLen);
+ If P<>Nil then
+ begin
+ PWideRec(P)^.Len:=Len*2; { Initial length }
+{$ifndef FPC_WINLIKEWIDESTRING}
+ PWideRec(P)^.Ref:=1; { Initial Refcount }
+{$endif FPC_WINLIKEWIDESTRING}
+ PWideRec(P)^.First:=#0; { Terminating #0 }
+ inc(p,WideFirstOff); { Points to string now }
+ end
+ else
+ WideStringError;
+ end;
+ NewWideString:=P;
+end;
+
+
+Procedure DisposeWideString(Var S : Pointer);
+{
+ Deallocates a WideString From the heap.
+}
+begin
+ If S=Nil then
+ exit;
+{$ifndef MSWINDOWS}
+ Dec (S,WideFirstOff);
+ Freemem(S);
+{$else MSWINDOWS}
+ if winwidestringalloc then
+ SysFreeString(S)
+ else
+ begin
+ Dec (S,WideFirstOff);
+ Freemem(S);
+ end;
+{$endif MSWINDOWS}
+ 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;
+{
+ Decreases the ReferenceCount of a non constant widestring;
+ If the reference count is zero, deallocate the string;
+}
+Type
+ pSizeInt = ^SizeInt;
+{$ifndef FPC_WINLIKEWIDESTRING}
+Var
+ l : pSizeInt;
+{$endif FPC_WINLIKEWIDESTRING}
+Begin
+ { Zero string }
+ if S=Nil then
+ exit;
+{$ifndef FPC_WINLIKEWIDESTRING}
+ { 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 ...
+ ... remove }
+{$else}
+ if not IsWideStringConstant(S) then
+{$endif FPC_WINLIKEWIDESTRING}
+ DisposeWideString(S);
+end;
+
+{ alias for internal use }
+Procedure fpc_WideStr_Decr_Ref (Var S : Pointer);[external name 'FPC_WIDESTR_DECR_REF'];
+
+Procedure fpc_WideStr_Incr_Ref(Var S : Pointer);[Public,Alias:'FPC_WIDESTR_INCR_REF']; compilerproc;
+{$ifdef FPC_WINLIKEWIDESTRING}
+ var
+ p : pointer;
+{$endif FPC_WINLIKEWIDESTRING}
+ Begin
+ If S=Nil then
+ exit;
+{$ifdef FPC_WINLIKEWIDESTRING}
+ p:=NewWidestring(length(WideString(S)));
+ move(s^,p^,(length(WideString(s))+1)*sizeof(widechar)); // double #0 too
+ s:=p;
+{$else FPC_WINLIKEWIDESTRING}
+ { Let's be paranoid : Constant string ??}
+ If PWideRec(S-WideFirstOff)^.Ref<0 then
+ exit;
+ inclocked(PWideRec(S-WideFirstOff)^.Ref);
+{$endif FPC_WINLIKEWIDESTRING}
+ end;
+
+{ alias for internal use }
+Procedure fpc_WideStr_Incr_Ref (Var S : Pointer);[external name 'FPC_WIDESTR_INCR_REF'];
+
+{$ifndef FPC_STRTOSHORTSTRINGPROC}
+function fpc_WideStr_To_ShortStr (high_of_res: SizeInt;const S2 : WideString): shortstring;[Public, alias: 'FPC_WIDESTR_TO_SHORTSTR']; compilerproc;
+{
+ Converts a WideString to a ShortString;
+}
+Var
+ Size : SizeInt;
+ temp : ansistring;
+begin
+ result:='';
+ Size:=Length(S2);
+ if Size>0 then
+ begin
+ If Size>high_of_res then
+ Size:=high_of_res;
+ widestringmanager.Wide2AnsiMoveProc(PWideChar(S2),temp,Size);
+ result:=temp;
+ end;
+end;
+{$else FPC_STRTOSHORTSTRINGPROC}
+procedure fpc_WideStr_To_ShortStr (out res: ShortString;const S2 : WideString); [Public, alias: 'FPC_WIDESTR_TO_SHORTSTR'];compilerproc;
+{
+ Converts a WideString to a ShortString;
+}
+Var
+ Size : SizeInt;
+ temp : ansistring;
+begin
+ res:='';
+ Size:=Length(S2);
+ if Size>0 then
+ begin
+ If Size>high(res) then
+ Size:=high(res);
+ widestringmanager.Wide2AnsiMoveProc(PWideChar(S2),temp,Size);
+ res:=temp;
+ end;
+end;
+{$endif FPC_STRTOSHORTSTRINGPROC}
+
+
+Function fpc_ShortStr_To_WideStr (Const S2 : ShortString): WideString;compilerproc;
+{
+ Converts a ShortString to a WideString;
+}
+Var
+ Size : SizeInt;
+begin
+ result:='';
+ Size:=Length(S2);
+ if Size>0 then
+ begin
+ widestringmanager.Ansi2WideMoveProc(PChar(@S2[1]),result,Size);
+ { Terminating Zero }
+ PWideChar(Pointer(fpc_ShortStr_To_WideStr)+Size*sizeof(WideChar))^:=#0;
+ end;
+end;
+
+
+Function fpc_WideStr_To_AnsiStr (const S2 : WideString): AnsiString; compilerproc;
+{
+ Converts a WideString to an AnsiString
+}
+Var
+ Size : SizeInt;
+begin
+ result:='';
+ Size:=Length(S2);
+ if Size>0 then
+ widestringmanager.Wide2AnsiMoveProc(PWideChar(Pointer(S2)),result,Size);
+end;
+
+
+Function fpc_AnsiStr_To_WideStr (Const S2 : AnsiString): WideString; compilerproc;
+{
+ Converts an AnsiString to a WideString;
+}
+Var
+ Size : SizeInt;
+begin
+ result:='';
+ Size:=Length(S2);
+ if Size>0 then
+ widestringmanager.Ansi2WideMoveProc(PChar(S2),result,Size);
+end;
+
+
+Function fpc_PWideChar_To_AnsiStr(const p : pwidechar): ansistring; compilerproc;
+var
+ Size : SizeInt;
+begin
+ result:='';
+ if p=nil then
+ exit;
+ Size := IndexWord(p^, -1, 0);
+ if Size>0 then
+ widestringmanager.Wide2AnsiMoveProc(P,result,Size);
+end;
+
+
+Function fpc_PWideChar_To_WideStr(const p : pwidechar): widestring; compilerproc;
+var
+ Size : SizeInt;
+begin
+ result:='';
+ if p=nil then
+ exit;
+ Size := IndexWord(p^, -1, 0);
+ Setlength(result,Size);
+ if Size>0 then
+ begin
+ Move(p^,PWideChar(Pointer(result))^,Size*sizeof(WideChar));
+ { Terminating Zero }
+ PWideChar(Pointer(result)+Size*sizeof(WideChar))^:=#0;
+ end;
+end;
+
+
+{$ifndef FPC_STRTOSHORTSTRINGPROC}
+Function fpc_PWideChar_To_ShortStr(const p : pwidechar): shortstring; compilerproc;
+var
+ Size : SizeInt;
+ temp: ansistring;
+begin
+ result:='';
+ if p=nil then
+ exit;
+ Size := IndexWord(p^, $7fffffff, 0);
+ if Size>0 then
+ begin
+ widestringmanager.Wide2AnsiMoveProc(p,temp,Size);
+ result:=temp;
+ end;
+end;
+{$else FPC_STRTOSHORTSTRINGPROC}
+procedure fpc_PWideChar_To_ShortStr(out res : shortstring;const p : pwidechar); compilerproc;
+var
+ Size : SizeInt;
+ temp: ansistring;
+begin
+ res:='';
+ if p=nil then
+ exit;
+ Size:=IndexWord(p^, high(PtrInt), 0);
+ if Size>0 then
+ begin
+ widestringmanager.Wide2AnsiMoveProc(p,temp,Size);
+ res:=temp;
+ end;
+end;
+{$endif FPC_STRTOSHORTSTRINGPROC}
+
+
+{ checked against the ansistring routine, 2001-05-27 (FK) }
+Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[Public,Alias:'FPC_WIDESTR_ASSIGN']; compilerproc;
+{
+ Assigns S2 to S1 (S1:=S2), taking in account reference counts.
+}
+begin
+{$ifdef FPC_WINLIKEWIDESTRING}
+ if S1=S2 then exit;
+ if S2<>nil then
+ begin
+ 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
+ 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
+ inclocked(PWideRec(S2-WideFirstOff)^.ref);
+ { Decrease the reference count on the old S1 }
+ fpc_widestr_decr_ref (S1);
+ s1:=s2;
+{$endif FPC_WINLIKEWIDESTRING}
+end;
+
+
+{ alias for internal use }
+Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[external name 'FPC_WIDESTR_ASSIGN'];
+
+{$ifndef STR_CONCAT_PROCS}
+
+function fpc_WideStr_Concat (const S1,S2 : WideString): WideString; compilerproc;
+Var
+ Size,Location : SizeInt;
+ pc : pwidechar;
+begin
+ { only assign if s1 or s2 is empty }
+ if (S1='') then
+ begin
+ result:=s2;
+ exit;
+ end;
+ if (S2='') then
+ begin
+ result:=s1;
+ exit;
+ end;
+ Location:=Length(S1);
+ Size:=length(S2);
+ SetLength(result,Size+Location);
+ pc:=pwidechar(result);
+ Move(S1[1],pc^,Location*sizeof(WideChar));
+ inc(pc,location);
+ Move(S2[1],pc^,(Size+1)*sizeof(WideChar));
+end;
+
+
+function fpc_WideStr_Concat_multi (const sarr:array of Widestring): widestring; compilerproc;
+Var
+ i : Longint;
+ p : pointer;
+ pc : pwidechar;
+ Size,NewSize : SizeInt;
+begin
+ { First calculate size of the result so we can do
+ a single call to SetLength() }
+ NewSize:=0;
+ for i:=low(sarr) to high(sarr) do
+ inc(Newsize,length(sarr[i]));
+ SetLength(result,NewSize);
+ pc:=pwidechar(result);
+ for i:=low(sarr) to high(sarr) do
+ begin
+ p:=pointer(sarr[i]);
+ if assigned(p) then
+ begin
+ Size:=length(widestring(p));
+ Move(pwidechar(p)^,pc^,(Size+1)*sizeof(WideChar));
+ inc(pc,size);
+ end;
+ end;
+end;
+
+{$else STR_CONCAT_PROCS}
+
+procedure fpc_WideStr_Concat (var DestS:Widestring;const S1,S2 : WideString); compilerproc;
+Var
+ Size,Location : SizeInt;
+ same : boolean;
+begin
+ { only assign if s1 or s2 is empty }
+ if (S1='') then
+ begin
+ DestS:=s2;
+ exit;
+ end;
+ if (S2='') then
+ begin
+ DestS:=s1;
+ exit;
+ end;
+ Location:=Length(S1);
+ Size:=length(S2);
+ { Use Pointer() typecasts to prevent extra conversion code }
+ if Pointer(DestS)=Pointer(S1) then
+ begin
+ same:=Pointer(S1)=Pointer(S2);
+ SetLength(DestS,Size+Location);
+ if same then
+ Move(Pointer(DestS)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size)*sizeof(WideChar))
+ else
+ Move(Pointer(S2)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
+ end
+ else if Pointer(DestS)=Pointer(S2) then
+ begin
+ SetLength(DestS,Size+Location);
+ Move(Pointer(DestS)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
+ Move(Pointer(S1)^,Pointer(DestS)^,Location*sizeof(WideChar));
+ end
+ else
+ begin
+ DestS:='';
+ SetLength(DestS,Size+Location);
+ Move(Pointer(S1)^,Pointer(DestS)^,Location*sizeof(WideChar));
+ Move(Pointer(S2)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
+ end;
+end;
+
+
+procedure fpc_WideStr_Concat_multi (var DestS:Widestring;const sarr:array of Widestring); compilerproc;
+Var
+ i : Longint;
+ p,pc : pointer;
+ Size,NewLen : SizeInt;
+{$ifndef FPC_WINLIKEWIDESTRING}
+ lowstart : longint;
+ destcopy : pointer;
+ OldDestLen : SizeInt;
+{$else FPC_WINLIKEWIDESTRING}
+ DestTmp : Widestring;
+{$endif FPC_WINLIKEWIDESTRING}
+begin
+ if high(sarr)=0 then
+ begin
+ DestS:='';
+ exit;
+ end;
+{$ifndef FPC_WINLIKEWIDESTRING}
+ destcopy:=nil;
+ lowstart:=low(sarr);
+ if Pointer(DestS)=Pointer(sarr[lowstart]) then
+ inc(lowstart);
+ { Check for another reuse, then we can't use
+ the append optimization }
+ for i:=lowstart to high(sarr) do
+ begin
+ if Pointer(DestS)=Pointer(sarr[i]) then
+ begin
+ { if DestS is used somewhere in the middle of the expression,
+ we need to make sure the original string still exists after
+ we empty/modify DestS.
+ This trick only works with reference counted strings. Therefor
+ this optimization is disabled for WINLIKEWIDESTRING }
+ destcopy:=pointer(dests);
+ fpc_WideStr_Incr_Ref(destcopy);
+ lowstart:=low(sarr);
+ break;
+ end;
+ end;
+ { Start with empty DestS if we start with concatting
+ the first array element }
+ if lowstart=low(sarr) then
+ DestS:='';
+ OldDestLen:=length(DestS);
+ { Calculate size of the result so we can do
+ a single call to SetLength() }
+ NewLen:=0;
+ for i:=low(sarr) to high(sarr) do
+ inc(NewLen,length(sarr[i]));
+ SetLength(DestS,NewLen);
+ { Concat all strings, except the string we already
+ copied in DestS }
+ pc:=Pointer(DestS)+OldDestLen*sizeof(WideChar);
+ for i:=lowstart to high(sarr) do
+ begin
+ p:=pointer(sarr[i]);
+ if assigned(p) then
+ begin
+ Size:=length(widestring(p));
+ Move(p^,pc^,(Size+1)*sizeof(WideChar));
+ inc(pc,size*sizeof(WideChar));
+ end;
+ end;
+ fpc_WideStr_Decr_Ref(destcopy);
+{$else FPC_WINLIKEWIDESTRING}
+ { First calculate size of the result so we can do
+ a single call to SetLength() }
+ NewLen:=0;
+ for i:=low(sarr) to high(sarr) do
+ inc(NewLen,length(sarr[i]));
+ SetLength(DestTmp,NewLen);
+ pc:=pwidechar(DestTmp);
+ for i:=low(sarr) to high(sarr) do
+ begin
+ p:=pointer(sarr[i]);
+ if assigned(p) then
+ begin
+ Size:=length(widestring(p));
+ Move(p^,pc^,(Size+1)*sizeof(WideChar));
+ inc(pc,size*sizeof(WideChar));
+ end;
+ end;
+ DestS:=DestTmp;
+{$endif FPC_WINLIKEWIDESTRING}
+end;
+
+{$endif STR_CONCAT_PROCS}
+
+Function fpc_Char_To_WChar(const c : Char): WideChar; compilerproc;
+var
+ w: widestring;
+begin
+ widestringmanager.Ansi2WideMoveProc(@c, w, 1);
+ fpc_Char_To_WChar:= w[1];
+end;
+
+
+
+Function fpc_Char_To_WideStr(const c : Char): WideString; compilerproc;
+{
+ Converts a Char to a WideString;
+}
+begin
+ Setlength(fpc_Char_To_WideStr,1);
+ fpc_Char_To_WideStr[1]:=c;
+ { Terminating Zero }
+ PWideChar(Pointer(fpc_Char_To_WideStr)+sizeof(WideChar))^:=#0;
+end;
+
+
+Function fpc_WChar_To_Char(const c : WideChar): Char; compilerproc;
+{
+ Converts a WideChar to a Char;
+}
+var
+ s: ansistring;
+begin
+ widestringmanager.Wide2AnsiMoveProc(@c, s, 1);
+ if length(s)=1 then
+ fpc_WChar_To_Char:= s[1]
+ else
+ fpc_WChar_To_Char:='?';
+end;
+
+
+Function fpc_WChar_To_WideStr(const c : WideChar): WideString; compilerproc;
+{
+ Converts a WideChar to a WideString;
+}
+begin
+ Setlength (fpc_WChar_To_WideStr,1);
+ fpc_WChar_To_WideStr[1]:= c;
+end;
+
+
+Function fpc_WChar_To_AnsiStr(const c : WideChar): AnsiString; compilerproc;
+{
+ Converts a WideChar to a AnsiString;
+}
+begin
+ widestringmanager.Wide2AnsiMoveProc(@c, fpc_WChar_To_AnsiStr, 1);
+end;
+
+
+{$ifndef FPC_STRTOSHORTSTRINGPROC}
+Function fpc_WChar_To_ShortStr(const c : WideChar): ShortString; compilerproc;
+{
+ Converts a WideChar to a ShortString;
+}
+var
+ s: ansistring;
+begin
+ widestringmanager.Wide2AnsiMoveProc(@c, s, 1);
+ fpc_WChar_To_ShortStr:= s;
+end;
+{$else FPC_STRTOSHORTSTRINGPROC}
+procedure fpc_WChar_To_ShortStr(out res : shortstring;const c : WideChar) compilerproc;
+{
+ Converts a WideChar to a ShortString;
+}
+var
+ s: ansistring;
+begin
+ widestringmanager.Wide2AnsiMoveProc(@c,s,1);
+ res:=s;
+end;
+{$endif FPC_STRTOSHORTSTRINGPROC}
+
+
+Function fpc_PChar_To_WideStr(const p : pchar): WideString; compilerproc;
+Var
+ L : SizeInt;
+begin
+ if (not assigned(p)) or (p[0]=#0) Then
+ begin
+ fpc_pchar_to_widestr := '';
+ exit;
+ end;
+ l:=IndexChar(p^,-1,#0);
+ widestringmanager.Ansi2WideMoveProc(P,fpc_PChar_To_WideStr,l);
+end;
+
+
+Function fpc_CharArray_To_WideStr(const arr: array of char; zerobased: boolean = true): WideString; compilerproc;
+var
+ i : SizeInt;
+begin
+ if (zerobased) then
+ begin
+ if (arr[0]=#0) Then
+ begin
+ fpc_chararray_to_widestr := '';
+ exit;
+ end;
+ i:=IndexChar(arr,high(arr)+1,#0);
+ if i = -1 then
+ i := high(arr)+1;
+ end
+ else
+ i := high(arr)+1;
+ SetLength(fpc_CharArray_To_WideStr,i);
+ widestringmanager.Ansi2WideMoveProc (pchar(@arr),fpc_CharArray_To_WideStr,i);
+end;
+
+
+{$ifndef FPC_STRTOSHORTSTRINGPROC}
+function fpc_WideCharArray_To_ShortStr(const arr: array of widechar; zerobased: boolean = true): shortstring;[public,alias:'FPC_WIDECHARARRAY_TO_SHORTSTR']; compilerproc;
+var
+ l: longint;
+ index: longint;
+ len: byte;
+ temp: ansistring;
+begin
+ l := high(arr)+1;
+ if l>=256 then
+ l:=255
+ else if l<0 then
+ l:=0;
+ if zerobased then
+ begin
+ index:=IndexWord(arr[0],l,0);
+ if (index < 0) then
+ len := l
+ else
+ len := index;
+ end
+ else
+ len := l;
+ widestringmanager.Wide2AnsiMoveProc (pwidechar(@arr),temp,len);
+ fpc_WideCharArray_To_ShortStr := temp;
+end;
+{$else FPC_STRTOSHORTSTRINGPROC}
+procedure fpc_WideCharArray_To_ShortStr(out res : shortstring;const arr: array of widechar; zerobased: boolean = true);[public,alias:'FPC_WIDECHARARRAY_TO_SHORTSTR']; compilerproc;
+var
+ l: longint;
+ index: ptrint;
+ len: byte;
+ temp: ansistring;
+begin
+ l := high(arr)+1;
+ if l>=high(res)+1 then
+ l:=high(res)
+ else if l<0 then
+ l:=0;
+ if zerobased then
+ begin
+ index:=IndexWord(arr[0],l,0);
+ if index<0 then
+ len:=l
+ else
+ len:=index;
+ end
+ else
+ len:=l;
+ widestringmanager.Wide2AnsiMoveProc (pwidechar(@arr),temp,len);
+ res:=temp;
+end;
+{$endif FPC_STRTOSHORTSTRINGPROC}
+
+Function fpc_WideCharArray_To_AnsiStr(const arr: array of widechar; zerobased: boolean = true): AnsiString; compilerproc;
+var
+ i : SizeInt;
+begin
+ if (zerobased) then
+ begin
+ i:=IndexWord(arr,high(arr)+1,0);
+ if i = -1 then
+ i := high(arr)+1;
+ end
+ else
+ i := high(arr)+1;
+ SetLength(fpc_WideCharArray_To_AnsiStr,i);
+ widestringmanager.Wide2AnsiMoveProc (pwidechar(@arr),fpc_WideCharArray_To_AnsiStr,i);
+end;
+
+Function fpc_WideCharArray_To_WideStr(const arr: array of widechar; zerobased: boolean = true): WideString; compilerproc;
+var
+ i : SizeInt;
+begin
+ if (zerobased) then
+ begin
+ i:=IndexWord(arr,high(arr)+1,0);
+ if i = -1 then
+ i := high(arr)+1;
+ end
+ else
+ i := high(arr)+1;
+ SetLength(fpc_WideCharArray_To_WideStr,i);
+ Move(arr[0], Pointer(fpc_WideCharArray_To_WideStr)^,i*sizeof(WideChar));
+end;
+
+{$ifndef FPC_STRTOCHARARRAYPROC}
+
+{ inside the compiler, the resulttype is modified to that of the actual }
+{ chararray we're converting to (JM) }
+function fpc_widestr_to_chararray(arraysize: SizeInt; const src: WideString): fpc_big_chararray;[public,alias: 'FPC_WIDESTR_TO_CHARARRAY']; compilerproc;
+var
+ len: SizeInt;
+ temp: ansistring;
+begin
+ len := length(src);
+ { make sure we don't dereference src if it can be nil (JM) }
+ if len > 0 then
+ widestringmanager.wide2ansimoveproc(pwidechar(@src[1]),temp,len);
+ len := length(temp);
+ if len > arraysize then
+ len := arraysize;
+{$r-}
+ move(temp[1],fpc_widestr_to_chararray[0],len);
+ fillchar(fpc_widestr_to_chararray[len],arraysize-len,0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+
+{ inside the compiler, the resulttype is modified to that of the actual }
+{ widechararray we're converting to (JM) }
+function fpc_widestr_to_widechararray(arraysize: SizeInt; const src: WideString): fpc_big_widechararray;[public,alias: 'FPC_WIDESTR_TO_WIDECHARARRAY']; compilerproc;
+var
+ len: SizeInt;
+begin
+ len := length(src);
+ if len > arraysize then
+ len := arraysize;
+{$r-}
+ { make sure we don't try to access element 1 of the ansistring if it's nil }
+ if len > 0 then
+ move(src[1],fpc_widestr_to_widechararray[0],len*SizeOf(WideChar));
+ fillchar(fpc_widestr_to_widechararray[len],(arraysize-len)*SizeOf(WideChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+
+{ inside the compiler, the resulttype is modified to that of the actual }
+{ chararray we're converting to (JM) }
+function fpc_ansistr_to_widechararray(arraysize: SizeInt; const src: AnsiString): fpc_big_widechararray;[public,alias: 'FPC_ANSISTR_TO_WIDECHARARRAY']; compilerproc;
+var
+ len: SizeInt;
+ temp: widestring;
+begin
+ len := length(src);
+ { make sure we don't dereference src if it can be nil (JM) }
+ if len > 0 then
+ widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
+ len := length(temp);
+ if len > arraysize then
+ len := arraysize;
+
+{$r-}
+ move(temp[1],fpc_ansistr_to_widechararray[0],len*sizeof(widechar));
+ fillchar(fpc_ansistr_to_widechararray[len],(arraysize-len)*SizeOf(WideChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+function fpc_shortstr_to_widechararray(arraysize: SizeInt; const src: ShortString): fpc_big_widechararray;[public,alias: 'FPC_SHORTSTR_TO_WIDECHARARRAY']; compilerproc;
+var
+ len: longint;
+ temp : widestring;
+begin
+ len := length(src);
+ { make sure we don't access char 1 if length is 0 (JM) }
+ if len > 0 then
+ widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
+ len := length(temp);
+ if len > arraysize then
+ len := arraysize;
+{$r-}
+ move(temp[1],fpc_shortstr_to_widechararray[0],len*sizeof(widechar));
+ fillchar(fpc_shortstr_to_widechararray[len],(arraysize-len)*SizeOf(WideChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+{$else ndef FPC_STRTOCHARARRAYPROC}
+
+procedure fpc_widestr_to_chararray(out res: array of char; const src: WideString); compilerproc;
+var
+ len: SizeInt;
+ temp: ansistring;
+begin
+ len := length(src);
+ { make sure we don't dereference src if it can be nil (JM) }
+ if len > 0 then
+ widestringmanager.wide2ansimoveproc(pwidechar(@src[1]),temp,len);
+ len := length(temp);
+ if len > length(res) then
+ len := length(res);
+{$r-}
+ move(temp[1],res[0],len);
+ fillchar(res[len],length(res)-len,0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+
+procedure fpc_widestr_to_widechararray(out res: array of widechar; const src: WideString); compilerproc;
+var
+ len: SizeInt;
+begin
+ len := length(src);
+ if len > length(res) then
+ len := length(res);
+{$r-}
+ { make sure we don't try to access element 1 of the ansistring if it's nil }
+ if len > 0 then
+ move(src[1],res[0],len*SizeOf(WideChar));
+ fillchar(res[len],(length(res)-len)*SizeOf(WideChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+
+procedure fpc_ansistr_to_widechararray(out res: array of widechar; const src: AnsiString); compilerproc;
+var
+ len: SizeInt;
+ temp: widestring;
+begin
+ len := length(src);
+ { make sure we don't dereference src if it can be nil (JM) }
+ if len > 0 then
+ widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
+ len := length(temp);
+ if len > length(res) then
+ len := length(res);
+
+{$r-}
+ move(temp[1],res[0],len*sizeof(widechar));
+ fillchar(res[len],(length(res)-len)*SizeOf(WideChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+procedure fpc_shortstr_to_widechararray(out res: array of widechar; const src: ShortString); compilerproc;
+var
+ len: longint;
+ temp : widestring;
+begin
+ len := length(src);
+ { make sure we don't access char 1 if length is 0 (JM) }
+ if len > 0 then
+ widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
+ len := length(temp);
+ if len > length(res) then
+ len := length(res);
+{$r-}
+ move(temp[1],res[0],len*sizeof(widechar));
+ fillchar(res[len],(length(res)-len)*SizeOf(WideChar),0);
+{$ifdef RangeCheckWasOn}
+{$r+}
+{$endif}
+end;
+
+{$endif ndef FPC_STRTOCHARARRAYPROC}
+
+Function fpc_WideStr_Compare(const S1,S2 : WideString): SizeInt;[Public,Alias : 'FPC_WIDESTR_COMPARE']; compilerproc;
+{
+ Compares 2 WideStrings;
+ The result is
+ <0 if S1<S2
+ 0 if S1=S2
+ >0 if S1>S2
+}
+Var
+ MaxI,Temp : SizeInt;
+begin
+ if pointer(S1)=pointer(S2) then
+ begin
+ fpc_WideStr_Compare:=0;
+ exit;
+ end;
+ Maxi:=Length(S1);
+ temp:=Length(S2);
+ If MaxI>Temp then
+ MaxI:=Temp;
+ Temp:=CompareWord(S1[1],S2[1],MaxI);
+ if temp=0 then
+ temp:=Length(S1)-Length(S2);
+ fpc_WideStr_Compare:=Temp;
+end;
+
+Function fpc_WideStr_Compare_Equal(const S1,S2 : WideString): SizeInt;[Public,Alias : 'FPC_WIDESTR_COMPARE_EQUAL']; compilerproc;
+{
+ Compares 2 WideStrings for equality only;
+ The result is
+ 0 if S1=S2
+ <>0 if S1<>S2
+}
+Var
+ MaxI : SizeInt;
+begin
+ if pointer(S1)=pointer(S2) then
+ exit(0);
+ Maxi:=Length(S1);
+ If MaxI<>Length(S2) then
+ exit(-1)
+ else
+ exit(CompareWord(S1[1],S2[1],MaxI));
+end;
+
+Procedure fpc_WideStr_CheckZero(p : pointer);[Public,Alias : 'FPC_WIDESTR_CHECKZERO']; compilerproc;
+begin
+ if p=nil then
+ HandleErrorFrame(201,get_frame);
+end;
+
+
+Procedure fpc_WideStr_CheckRange(len,index : SizeInt);[Public,Alias : 'FPC_WIDESTR_RANGECHECK']; compilerproc;
+begin
+ if (index>len div 2) or (Index<1) then
+ HandleErrorFrame(201,get_frame);
+end;
+
+Procedure fpc_WideStr_SetLength(Var S : WideString; l : SizeInt);[Public,Alias : 'FPC_WIDESTR_SETLENGTH']; compilerproc;
+{
+ Sets The length of string S to L.
+ Makes sure S is unique, and contains enough room.
+}
+Var
+ Temp : Pointer;
+ movelen: SizeInt;
+begin
+ if (l>0) then
+ begin
+ if Pointer(S)=nil then
+ begin
+ { Need a complete new string...}
+ Pointer(s):=NewWideString(l);
+ end
+ { windows doesn't support reallocing widestrings, this code
+ is anyways subject to be removed because widestrings shouldn't be
+ ref. counted anymore (FK) }
+ else
+ if
+{$ifdef MSWINDOWS}
+ not winwidestringalloc and
+{$endif MSWINDOWS}
+{$ifdef FPC_WINLIKEWIDESTRING}
+ not IsWideStringConstant(pointer(S))
+{$else}
+ (PWideRec(Pointer(S)-WideFirstOff)^.Ref = 1)
+{$endif FPC_WINLIKEWIDESTRING}
+ then
+ begin
+ Dec(Pointer(S),WideFirstOff);
+ if SizeUInt(L*sizeof(WideChar)+WideRecLen)>MemSize(Pointer(S)) then
+ reallocmem(pointer(S), L*sizeof(WideChar)+WideRecLen);
+ Inc(Pointer(S), WideFirstOff);
+ end
+ else
+ begin
+ { Reallocation is needed... }
+ Temp:=Pointer(NewWideString(L));
+ if Length(S)>0 then
+ begin
+ if l < succ(length(s)) then
+ movelen := l
+ { also move terminating null }
+ else
+ movelen := succ(length(s));
+ Move(Pointer(S)^,Temp^,movelen * Sizeof(WideChar));
+ end;
+ fpc_widestr_decr_ref(Pointer(S));
+ Pointer(S):=Temp;
+ end;
+ { Force nil termination in case it gets shorter }
+ PWord(Pointer(S)+l*sizeof(WideChar))^:=0;
+{$ifdef MSWINDOWS}
+ if not winwidestringalloc then
+{$endif MSWINDOWS}
+ PWideRec(Pointer(S)-WideFirstOff)^.Len:=l*sizeof(WideChar);
+ 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.
+*****************************************************************************}
+
+function WideCharToString(S : PWideChar) : AnsiString;
+ begin
+ result:=WideCharLenToString(s,Length(WideString(s)));
+ end;
+
+function StringToWideChar(const Src : AnsiString;Dest : PWideChar;DestSize : SizeInt) : PWideChar;
+ var
+ temp:widestring;
+ begin
+ widestringmanager.Ansi2WideMoveProc(PChar(Src),temp,Length(Src));
+ if Length(temp)<DestSize then
+ move(temp[1],Dest^,Length(temp)*SizeOf(WideChar))
+ else
+ move(temp[1],Dest^,(DestSize-1)*SizeOf(WideChar));
+
+ Dest[DestSize-1]:=#0;
+
+ result:=Dest;
+
+ end;
+
+function WideCharLenToString(S : PWideChar;Len : SizeInt) : AnsiString;
+ begin
+ //SetLength(result,Len);
+ widestringmanager.Wide2AnsiMoveproc(S,result,Len);
+ end;
+
+procedure WideCharLenToStrVar(Src : PWideChar;Len : SizeInt;out Dest : AnsiString);
+ begin
+ Dest:=WideCharLenToString(Src,Len);
+ end;
+
+procedure WideCharToStrVar(S : PWideChar;out Dest : AnsiString);
+ begin
+ Dest:=WideCharToString(S);
+ end;
+
+
+Function fpc_widestr_Unique(Var S : Pointer): Pointer; [Public,Alias : 'FPC_WIDESTR_UNIQUE']; compilerproc;
+{$ifdef FPC_WINLIKEWIDESTRING}
+ begin
+ pointer(result) := pointer(s);
+ end;
+{$else FPC_WINLIKEWIDESTRING}
+{
+ Make sure reference count of S is 1,
+ using copy-on-write semantics.
+}
+Var
+ SNew : Pointer;
+ L : SizeInt;
+begin
+ pointer(result) := pointer(s);
+ If Pointer(S)=Nil then
+ exit;
+ if PWideRec(Pointer(S)-WideFirstOff)^.Ref<>1 then
+ begin
+ L:=PWideRec(Pointer(S)-WideFirstOff)^.len div sizeof(WideChar);
+ SNew:=NewWideString (L);
+ Move (PWideChar(S)^,SNew^,(L+1)*sizeof(WideChar));
+ PWideRec(SNew-WideFirstOff)^.len:=L * sizeof(WideChar);
+ fpc_widestr_decr_ref (Pointer(S)); { Thread safe }
+ pointer(S):=SNew;
+ pointer(result):=SNew;
+ end;
+end;
+{$endif FPC_WINLIKEWIDESTRING}
+
+
+Function Fpc_WideStr_Copy (Const S : WideString; Index,Size : SizeInt) : WideString;compilerproc;
+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*sizeof(WideChar);
+ PWideChar(ResultAddress+Size*sizeof(WideChar))^:=#0;
+ end;
+ end;
+ fpc_widestr_decr_ref(Pointer(fpc_widestr_copy));
+ Pointer(fpc_widestr_Copy):=ResultAddress;
+end;
+
+
+Function Pos (Const Substr : WideString; Const Source : WideString) : SizeInt;
+var
+ i,MaxLen : SizeInt;
+ 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) : SizeInt;
+var
+ i: SizeInt;
+ 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;
+
+
+Function Pos (c : WideChar; Const s : AnsiString) : SizeInt;
+ begin
+ result:=Pos(c,WideString(s));
+ end;
+
+
+Function Pos (c : AnsiString; Const s : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ result:=Pos(WideString(c),s);
+ end;
+
+
+Function Pos (c : ShortString; Const s : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ result:=Pos(WideString(c),s);
+ end;
+
+
+Function Pos (c : WideString; Const s : AnsiString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ result:=Pos(c,WideString(s));
+ 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) : SizeInt;
+var
+ i: SizeInt;
+ 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: SizeInt);
+Var
+ LS : SizeInt;
+begin
+ If Length(S)=0 then
+ exit;
+ if index<=0 then
+ exit;
+ LS:=PWideRec(Pointer(S)-WideFirstOff)^.Len div sizeof(WideChar);
+ 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-Size+1)*sizeof(WideChar));
+ end;
+ Setlength(s,LS-Size);
+ end;
+end;
+
+
+Procedure Insert (Const Source : WideString; Var S : WideString; Index : SizeInt);
+var
+ Temp : WideString;
+ LS : SizeInt;
+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;
+
+
+function UpCase(const s : WideString) : WideString;
+begin
+ result:=widestringmanager.UpperWideStringProc(s);
+end;
+
+
+Procedure SetString (Out S : WideString; Buf : PWideChar; Len : SizeInt);
+var
+ BufLen: SizeInt;
+begin
+ SetLength(S,Len);
+ If (Buf<>Nil) and (Len>0) then
+ begin
+ BufLen := IndexWord(Buf^, Len+1, 0);
+ If (BufLen>0) and (BufLen < Len) then
+ Len := BufLen;
+ Move (Buf[0],S[1],Len*sizeof(WideChar));
+ PWideChar(Pointer(S)+Len*sizeof(WideChar))^:=#0;
+ end;
+end;
+
+
+Procedure SetString (Out S : WideString; Buf : PChar; Len : SizeInt);
+var
+ BufLen: SizeInt;
+begin
+ SetLength(S,Len);
+ If (Buf<>Nil) and (Len>0) then
+ begin
+ BufLen := IndexByte(Buf^, Len+1, 0);
+ If (BufLen>0) and (BufLen < Len) then
+ Len := BufLen;
+ widestringmanager.Ansi2WideMoveProc(Buf,S,Len);
+ //PWideChar(Pointer(S)+Len*sizeof(WideChar))^:=#0;
+ end;
+end;
+
+
+{$ifndef FPUNONE}
+Function fpc_Val_Real_WideStr(Const S : WideString; out Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_WIDESTR']; compilerproc;
+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;
+{$endif}
+
+function fpc_val_enum_widestr(str2ordindex:pointer;const s:widestring;out code:valsint):longint;compilerproc;
+
+var ss:shortstring;
+
+begin
+ if length(s)>255 then
+ code:=256
+ else
+ begin
+ ss:=s;
+ val(ss,fpc_val_enum_widestr,code);
+ end;
+end;
+
+Function fpc_Val_Currency_WideStr(Const S : WideString; out Code : ValSInt): Currency; [public, alias:'FPC_VAL_CURRENCY_WIDESTR']; compilerproc;
+Var
+ SS : String;
+begin
+ if length(S) > 255 then
+ begin
+ fpc_Val_Currency_WideStr:=0;
+ code := 256;
+ end
+ else
+ begin
+ SS := S;
+ Val(SS,fpc_Val_Currency_WideStr,code);
+ end;
+end;
+
+
+Function fpc_Val_UInt_WideStr (Const S : WideString; out Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_WIDESTR']; compilerproc;
+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: SizeInt; Const S : WideString; out Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_WIDESTR']; compilerproc;
+Var
+ SS : ShortString;
+begin
+ fpc_Val_SInt_WideStr:=0;
+ if length(S)>255 then
+ code:=256
+ else
+ begin
+ SS := S;
+ fpc_Val_SInt_WideStr := int_Val_SInt_ShortStr(DestSize,SS,Code);
+ end;
+end;
+
+
+{$ifndef CPU64}
+
+Function fpc_Val_qword_WideStr (Const S : WideString; out Code : ValSInt): qword; [public, alias:'FPC_VAL_QWORD_WIDESTR']; compilerproc;
+Var
+ SS : ShortString;
+begin
+ fpc_Val_qword_WideStr:=0;
+ if length(S)>255 then
+ code:=256
+ else
+ begin
+ SS := S;
+ Val(SS,fpc_Val_qword_WideStr,Code);
+ end;
+end;
+
+
+Function fpc_Val_int64_WideStr (Const S : WideString; out Code : ValSInt): Int64; [public, alias:'FPC_VAL_INT64_WIDESTR']; compilerproc;
+Var
+ SS : ShortString;
+begin
+ fpc_Val_int64_WideStr:=0;
+ if length(S)>255 then
+ code:=256
+ else
+ begin
+ SS := S;
+ Val(SS,fpc_Val_int64_WideStr,Code);
+ end;
+end;
+
+{$endif CPU64}
+
+
+{$ifndef FPUNONE}
+procedure fpc_WideStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : WideString);compilerproc;
+var
+ ss : shortstring;
+begin
+ str_real(len,fr,d,treal_type(rt),ss);
+ s:=ss;
+end;
+{$endif}
+
+procedure fpc_widestr_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:widestring);compilerproc;
+
+var ss:shortstring;
+
+begin
+ fpc_shortstr_enum(ordinal,len,typinfo,ord2strindex,ss);
+ s:=ss;
+end;
+
+{$ifdef FPC_HAS_STR_CURRENCY}
+procedure fpc_WideStr_Currency(c : Currency;len,fr : SizeInt;out s : WideString);compilerproc;
+var
+ ss : shortstring;
+begin
+ str(c:len:fr,ss);
+ s:=ss;
+end;
+{$endif FPC_HAS_STR_CURRENCY}
+
+Procedure fpc_WideStr_SInt(v : ValSint; Len : SizeInt; out S : WideString);compilerproc;
+Var
+ SS : ShortString;
+begin
+ Str (v:Len,SS);
+ S:=SS;
+end;
+
+
+Procedure fpc_WideStr_UInt(v : ValUInt;Len : SizeInt; out S : WideString);compilerproc;
+Var
+ SS : ShortString;
+begin
+ str(v:Len,SS);
+ S:=SS;
+end;
+
+
+{$ifndef CPU64}
+
+Procedure fpc_WideStr_Int64(v : Int64; Len : SizeInt; out S : WideString);compilerproc;
+Var
+ SS : ShortString;
+begin
+ Str (v:Len,SS);
+ S:=SS;
+end;
+
+
+Procedure fpc_WideStr_Qword(v : Qword;Len : SizeInt; out S : WideString);compilerproc;
+Var
+ SS : ShortString;
+begin
+ str(v:Len,SS);
+ S:=SS;
+end;
+
+{$endif CPU64}
+
+function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ if assigned(Source) then
+ Result:=UnicodeToUtf8(Dest,MaxBytes,Source,IndexWord(Source^,-1,0))
+ else
+ Result:=0;
+ end;
+
+
+function UnicodeToUtf8(Dest: PChar; MaxDestBytes: SizeUInt; Source: PWideChar; SourceChars: SizeUInt): SizeUInt;
+ var
+ i,j : SizeUInt;
+ w : word;
+ begin
+ result:=0;
+ if source=nil then
+ exit;
+ i:=0;
+ j:=0;
+ if assigned(Dest) then
+ begin
+ while (i<SourceChars) and (j<MaxDestBytes) do
+ begin
+ w:=word(Source[i]);
+ case w of
+ 0..$7f:
+ begin
+ Dest[j]:=char(w);
+ inc(j);
+ end;
+ $80..$7ff:
+ begin
+ if j+1>=MaxDestBytes then
+ break;
+ Dest[j]:=char($c0 or (w shr 6));
+ Dest[j+1]:=char($80 or (w and $3f));
+ inc(j,2);
+ end;
+ else
+ begin
+ if j+2>=MaxDestBytes then
+ break;
+ Dest[j]:=char($e0 or (w shr 12));
+ Dest[j+1]:=char($80 or ((w shr 6)and $3f));
+ Dest[j+2]:=char($80 or (w and $3f));
+ inc(j,3);
+ end;
+ end;
+ inc(i);
+ end;
+
+ if j>SizeUInt(MaxDestBytes-1) then
+ j:=MaxDestBytes-1;
+
+ Dest[j]:=#0;
+ end
+ else
+ begin
+ while i<SourceChars do
+ begin
+ case word(Source[i]) of
+ $0..$7f:
+ inc(j);
+ $80..$7ff:
+ inc(j,2);
+ else
+ inc(j,3);
+ end;
+ inc(i);
+ end;
+ end;
+ result:=j+1;
+ end;
+
+
+function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ if assigned(Source) then
+ Result:=Utf8ToUnicode(Dest,MaxChars,Source,strlen(Source))
+ else
+ Result:=0;
+ end;
+
+
+function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: SizeUInt; Source: PChar; SourceBytes: SizeUInt): SizeUInt;
+
+var
+ i,j : SizeUInt;
+ w: SizeUInt;
+ b : byte;
+begin
+ if not assigned(Source) then
+ begin
+ result:=0;
+ exit;
+ end;
+ result:=SizeUInt(-1);
+ i:=0;
+ j:=0;
+ if assigned(Dest) then
+ begin
+ while (j<MaxDestChars) and (i<SourceBytes) do
+ begin
+ b:=byte(Source[i]);
+ w:=b;
+ inc(i);
+ // 2 or 3 bytes?
+ if b>=$80 then
+ begin
+ w:=b and $3f;
+ if i>=SourceBytes then
+ exit;
+ // 3 bytes?
+ if (b and $20)<>0 then
+ begin
+ b:=byte(Source[i]);
+ inc(i);
+ if i>=SourceBytes then
+ exit;
+ if (b and $c0)<>$80 then
+ exit;
+ w:=(w shl 6) or (b and $3f);
+ end;
+ b:=byte(Source[i]);
+ w:=(w shl 6) or (b and $3f);
+ if (b and $c0)<>$80 then
+ exit;
+ inc(i);
+ end;
+ Dest[j]:=WideChar(w);
+ inc(j);
+ end;
+ if j>=MaxDestChars then j:=MaxDestChars-1;
+ Dest[j]:=#0;
+ end
+ else
+ begin
+ while i<SourceBytes do
+ begin
+ b:=byte(Source[i]);
+ inc(i);
+ // 2 or 3 bytes?
+ if b>=$80 then
+ begin
+ if i>=SourceBytes then
+ exit;
+ // 3 bytes?
+ b := b and $3f;
+ if (b and $20)<>0 then
+ begin
+ b:=byte(Source[i]);
+ inc(i);
+ if i>=SourceBytes then
+ exit;
+ if (b and $c0)<>$80 then
+ exit;
+ end;
+ if (byte(Source[i]) and $c0)<>$80 then
+ exit;
+ inc(i);
+ end;
+ inc(j);
+ end;
+ end;
+ result:=j+1;
+end;
+
+
+function UTF8Encode(const s : WideString) : UTF8String;
+ var
+ i : SizeInt;
+ hs : UTF8String;
+ begin
+ result:='';
+ if s='' then
+ exit;
+ SetLength(hs,length(s)*3);
+ i:=UnicodeToUtf8(pchar(hs),length(hs)+1,PWideChar(s),length(s));
+ if i>0 then
+ begin
+ SetLength(hs,i-1);
+ result:=hs;
+ end;
+ end;
+
+
+function UTF8Decode(const s : UTF8String): WideString;
+ var
+ i : SizeInt;
+ hs : WideString;
+ begin
+ result:='';
+ if s='' then
+ exit;
+ SetLength(hs,length(s));
+ i:=Utf8ToUnicode(PWideChar(hs),length(hs)+1,pchar(s),length(s));
+ if i>0 then
+ begin
+ SetLength(hs,i-1);
+ result:=hs;
+ end;
+ end;
+
+
+function AnsiToUtf8(const s : ansistring): UTF8String;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ Result:=Utf8Encode(s);
+ end;
+
+
+function Utf8ToAnsi(const s : UTF8String) : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
+ begin
+ Result:=Utf8Decode(s);
+ end;
+
+
+{ converts an utf-16 code point or surrogate pair to utf-32 }
+function utf16toutf32(const S: WideString; const index: SizeInt; out len: longint): UCS4Char; [public, alias: 'FPC_UTF16TOUTF32'];
+var
+ w: widechar;
+begin
+ { UTF-16 points in the range #$0-#$D7FF and #$E000-#$FFFF }
+ { are the same in UTF-32 }
+ w:=s[index];
+ if (w<=#$d7ff) or
+ (w>=#$e000) then
+ begin
+ result:=UCS4Char(w);
+ len:=1;
+ end
+ { valid surrogate pair? }
+ else if (w<=#$dbff) and
+ { w>=#$d7ff check not needed, checked above }
+ (index<length(s)) and
+ (s[index+1]>=#$dc00) and
+ (s[index+1]<=#$dfff) then
+ { convert the surrogate pair to UTF-32 }
+ begin
+ result:=(UCS4Char(w)-$d800) shl 10 + (UCS4Char(s[index+1])-$dc00) + $10000;
+ len:=2;
+ end
+ else
+ { invalid surrogate -> do nothing }
+ begin
+ result:=UCS4Char(w);
+ len:=1;
+ end;
+end;
+
+
+function WideStringToUCS4String(const s : WideString) : UCS4String;
+ var
+ i, slen,
+ destindex : SizeInt;
+ len : longint;
+ begin
+ slen:=length(s);
+ setlength(result,slen+1);
+ i:=1;
+ destindex:=0;
+ while (i<=slen) do
+ begin
+ result[destindex]:=utf16toutf32(s,i,len);
+ inc(destindex);
+ inc(i,len);
+ end;
+ { destindex <= slen (surrogate pairs may have been merged) }
+ { destindex+1 for terminating #0 (dynamic arrays are }
+ { implicitely filled with zero) }
+ setlength(result,destindex+1);
+ end;
+
+
+{ concatenates an utf-32 char to a widestring. S *must* be unique when entering. }
+procedure ConcatUTF32ToWideStr(const nc: UCS4Char; var S: WideString; var index: SizeInt);
+var
+ p : PWideChar;
+begin
+ { if nc > $ffff, we need two places }
+ if (index+ord(nc > $ffff)>length(s)) then
+ if (length(s) < 10*256) then
+ setlength(s,length(s)+10)
+ else
+ setlength(s,length(s)+length(s) shr 8);
+ { we know that s is unique -> avoid uniquestring calls}
+ p:=@s[index];
+ if (nc<$ffff) then
+ begin
+ p^:=widechar(nc);
+ inc(index);
+ end
+ else if (dword(nc)<=$10ffff) then
+ begin
+ p^:=widechar((nc - $10000) shr 10 + $d800);
+ (p+1)^:=widechar((nc - $10000) and $3ff + $dc00);
+ inc(index,2);
+ end
+ else
+ { invalid code point }
+ begin
+ p^:='?';
+ inc(index);
+ end;
+end;
+
+
+function UCS4StringToWideString(const s : UCS4String) : WideString;
+ var
+ i : SizeInt;
+ resindex : SizeInt;
+ begin
+ { skip terminating #0 }
+ SetLength(result,length(s)-1);
+ resindex:=1;
+ for i:=0 to high(s)-1 do
+ ConcatUTF32ToWideStr(s[i],result,resindex);
+ { adjust result length (may be too big due to growing }
+ { for surrogate pairs) }
+ setlength(result,resindex-1);
+ end;
+
+const
+ SNoWidestrings = 'This binary has no widestrings support compiled in.';
+ SRecompileWithWidestrings = 'Recompile the application with a widestrings-manager in the program uses clause.';
+
+procedure unimplementedwidestring;
+ begin
+{$ifdef FPC_HAS_FEATURE_CONSOLEIO}
+ If IsConsole then
+ begin
+ Writeln(StdErr,SNoWidestrings);
+ Writeln(StdErr,SRecompileWithWidestrings);
+ end;
+{$endif FPC_HAS_FEATURE_CONSOLEIO}
+ HandleErrorFrame(233,get_frame);
+ end;
+
+{$warnings off}
+function GenericWideCase(const s : WideString) : WideString;
+ begin
+ unimplementedwidestring;
+ end;
+
+
+function CompareWideString(const s1, s2 : WideString) : PtrInt;
+ begin
+ unimplementedwidestring;
+ end;
+
+
+function CompareTextWideString(const s1, s2 : WideString): PtrInt;
+ begin
+ unimplementedwidestring;
+ end;
+
+
+function CharLengthPChar(const Str: PChar): PtrInt;
+ begin
+ unimplementedwidestring;
+ end;
+{$warnings on}
+
+procedure initwidestringmanager;
+ begin
+ fillchar(widestringmanager,sizeof(widestringmanager),0);
+{$ifndef HAS_WIDESTRINGMANAGER}
+ widestringmanager.Wide2AnsiMoveProc:=@defaultWide2AnsiMove;
+ widestringmanager.Ansi2WideMoveProc:=@defaultAnsi2WideMove;
+ widestringmanager.UpperWideStringProc:=@GenericWideCase;
+ widestringmanager.LowerWideStringProc:=@GenericWideCase;
+{$endif HAS_WIDESTRINGMANAGER}
+ widestringmanager.CompareWideStringProc:=@CompareWideString;
+ widestringmanager.CompareTextWideStringProc:=@CompareTextWideString;
+ widestringmanager.CharLengthPCharProc:=@CharLengthPChar;
+ end;
diff --git a/rtl/inc/wustrings.inc b/rtl/inc/wustrings.inc
index e521e6156a..0e383565da 100644
--- a/rtl/inc/wustrings.inc
+++ b/rtl/inc/wustrings.inc
@@ -14,1989 +14,3 @@
**********************************************************************}
-{
- 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 :
-
- @-8 : SizeInt for reference count;
- @-4 : SizeInt for size; size=number of bytes, not the number of chars. Divide or multiply
- with sizeof(WideChar) to convert. This is needed to be compatible with Delphi and
- Windows COM BSTR.
- @ : 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
-{$ifdef FPC_WINLIKEWIDESTRING}
- Len : DWord;
-{$else FPC_WINLIKEWIDESTRING}
- Ref : SizeInt;
- Len : SizeInt;
-{$endif FPC_WINLIKEWIDESTRING}
- 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 DefaultWide2AnsiMove(source:pwidechar;var dest:ansistring;len:SizeInt);
-var
- i : SizeInt;
-begin
- setlength(dest,len);
- for i:=1 to len do
- begin
- if word(source^)<256 then
- dest[i]:=char(word(source^))
- else
- dest[i]:='?';
- inc(source);
- end;
-end;
-
-
-procedure DefaultAnsi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
-var
- i : SizeInt;
-begin
- setlength(dest,len);
- for i:=1 to len do
- begin
- dest[i]:=widechar(byte(source^));
- inc(source);
- end;
-end;
-
-
-Procedure GetWideStringManager (Var Manager : TWideStringManager);
-begin
- manager:=widestringmanager;
-end;
-
-
-Procedure SetWideStringManager (Const New : TWideStringManager; Var Old: TWideStringManager);
-begin
- Old:=widestringmanager;
- widestringmanager:=New;
-end;
-
-
-Procedure SetWideStringManager (Const New : TWideStringManager);
-begin
- widestringmanager:=New;
-end;
-
-(*
-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.
-****************************************************************************}
-
-
-procedure WideStringError;
- begin
- HandleErrorFrame(204,get_frame);
- end;
-
-
-{$ifdef WideStrDebug}
-Procedure DumpWideRec(S : Pointer);
-begin
- If S=Nil then
- Writeln ('String is nil')
- Else
- Begin
- With PWideRec(S-WideFirstOff)^ do
- begin
- Write ('(Len:',len);
- Writeln (' Ref: ',ref,')');
- end;
- end;
-end;
-{$endif}
-
-
-Function NewWideString(Len : SizeInt) : Pointer;
-{
- Allocate a new WideString on the heap.
- initialize it to zero length and reference count 1.
-}
-Var
- P : Pointer;
-begin
-{$ifdef MSWINDOWS}
- if winwidestringalloc then
- begin
- P:=SysAllocStringLen(nil,Len);
- if P=nil then
- WideStringError;
- end
- else
-{$endif MSWINDOWS}
- begin
- GetMem(P,Len*sizeof(WideChar)+WideRecLen);
- If P<>Nil then
- begin
- PWideRec(P)^.Len:=Len*2; { Initial length }
-{$ifndef FPC_WINLIKEWIDESTRING}
- PWideRec(P)^.Ref:=1; { Initial Refcount }
-{$endif FPC_WINLIKEWIDESTRING}
- PWideRec(P)^.First:=#0; { Terminating #0 }
- inc(p,WideFirstOff); { Points to string now }
- end
- else
- WideStringError;
- end;
- NewWideString:=P;
-end;
-
-
-Procedure DisposeWideString(Var S : Pointer);
-{
- Deallocates a WideString From the heap.
-}
-begin
- If S=Nil then
- exit;
-{$ifndef MSWINDOWS}
- Dec (S,WideFirstOff);
- Freemem(S);
-{$else MSWINDOWS}
- if winwidestringalloc then
- SysFreeString(S)
- else
- begin
- Dec (S,WideFirstOff);
- Freemem(S);
- end;
-{$endif MSWINDOWS}
- 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;
-{
- Decreases the ReferenceCount of a non constant widestring;
- If the reference count is zero, deallocate the string;
-}
-Type
- pSizeInt = ^SizeInt;
-{$ifndef FPC_WINLIKEWIDESTRING}
-Var
- l : pSizeInt;
-{$endif FPC_WINLIKEWIDESTRING}
-Begin
- { Zero string }
- if S=Nil then
- exit;
-{$ifndef FPC_WINLIKEWIDESTRING}
- { 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 ...
- ... remove }
-{$else}
- if not IsWideStringConstant(S) then
-{$endif FPC_WINLIKEWIDESTRING}
- DisposeWideString(S);
-end;
-
-{ alias for internal use }
-Procedure fpc_WideStr_Decr_Ref (Var S : Pointer);[external name 'FPC_WIDESTR_DECR_REF'];
-
-Procedure fpc_WideStr_Incr_Ref(Var S : Pointer);[Public,Alias:'FPC_WIDESTR_INCR_REF']; compilerproc;
-{$ifdef FPC_WINLIKEWIDESTRING}
- var
- p : pointer;
-{$endif FPC_WINLIKEWIDESTRING}
- Begin
- If S=Nil then
- exit;
-{$ifdef FPC_WINLIKEWIDESTRING}
- p:=NewWidestring(length(WideString(S)));
- move(s^,p^,(length(WideString(s))+1)*sizeof(widechar)); // double #0 too
- s:=p;
-{$else FPC_WINLIKEWIDESTRING}
- { Let's be paranoid : Constant string ??}
- If PWideRec(S-WideFirstOff)^.Ref<0 then
- exit;
- inclocked(PWideRec(S-WideFirstOff)^.Ref);
-{$endif FPC_WINLIKEWIDESTRING}
- end;
-
-{ alias for internal use }
-Procedure fpc_WideStr_Incr_Ref (Var S : Pointer);[external name 'FPC_WIDESTR_INCR_REF'];
-
-{$ifndef FPC_STRTOSHORTSTRINGPROC}
-function fpc_WideStr_To_ShortStr (high_of_res: SizeInt;const S2 : WideString): shortstring;[Public, alias: 'FPC_WIDESTR_TO_SHORTSTR']; compilerproc;
-{
- Converts a WideString to a ShortString;
-}
-Var
- Size : SizeInt;
- temp : ansistring;
-begin
- result:='';
- Size:=Length(S2);
- if Size>0 then
- begin
- If Size>high_of_res then
- Size:=high_of_res;
- widestringmanager.Wide2AnsiMoveProc(PWideChar(S2),temp,Size);
- result:=temp;
- end;
-end;
-{$else FPC_STRTOSHORTSTRINGPROC}
-procedure fpc_WideStr_To_ShortStr (out res: ShortString;const S2 : WideString); [Public, alias: 'FPC_WIDESTR_TO_SHORTSTR'];compilerproc;
-{
- Converts a WideString to a ShortString;
-}
-Var
- Size : SizeInt;
- temp : ansistring;
-begin
- res:='';
- Size:=Length(S2);
- if Size>0 then
- begin
- If Size>high(res) then
- Size:=high(res);
- widestringmanager.Wide2AnsiMoveProc(PWideChar(S2),temp,Size);
- res:=temp;
- end;
-end;
-{$endif FPC_STRTOSHORTSTRINGPROC}
-
-
-Function fpc_ShortStr_To_WideStr (Const S2 : ShortString): WideString;compilerproc;
-{
- Converts a ShortString to a WideString;
-}
-Var
- Size : SizeInt;
-begin
- result:='';
- Size:=Length(S2);
- if Size>0 then
- begin
- widestringmanager.Ansi2WideMoveProc(PChar(@S2[1]),result,Size);
- { Terminating Zero }
- PWideChar(Pointer(fpc_ShortStr_To_WideStr)+Size*sizeof(WideChar))^:=#0;
- end;
-end;
-
-
-Function fpc_WideStr_To_AnsiStr (const S2 : WideString): AnsiString; compilerproc;
-{
- Converts a WideString to an AnsiString
-}
-Var
- Size : SizeInt;
-begin
- result:='';
- Size:=Length(S2);
- if Size>0 then
- widestringmanager.Wide2AnsiMoveProc(PWideChar(Pointer(S2)),result,Size);
-end;
-
-
-Function fpc_AnsiStr_To_WideStr (Const S2 : AnsiString): WideString; compilerproc;
-{
- Converts an AnsiString to a WideString;
-}
-Var
- Size : SizeInt;
-begin
- result:='';
- Size:=Length(S2);
- if Size>0 then
- widestringmanager.Ansi2WideMoveProc(PChar(S2),result,Size);
-end;
-
-
-Function fpc_PWideChar_To_AnsiStr(const p : pwidechar): ansistring; compilerproc;
-var
- Size : SizeInt;
-begin
- result:='';
- if p=nil then
- exit;
- Size := IndexWord(p^, -1, 0);
- if Size>0 then
- widestringmanager.Wide2AnsiMoveProc(P,result,Size);
-end;
-
-
-Function fpc_PWideChar_To_WideStr(const p : pwidechar): widestring; compilerproc;
-var
- Size : SizeInt;
-begin
- result:='';
- if p=nil then
- exit;
- Size := IndexWord(p^, -1, 0);
- Setlength(result,Size);
- if Size>0 then
- begin
- Move(p^,PWideChar(Pointer(result))^,Size*sizeof(WideChar));
- { Terminating Zero }
- PWideChar(Pointer(result)+Size*sizeof(WideChar))^:=#0;
- end;
-end;
-
-
-{$ifndef FPC_STRTOSHORTSTRINGPROC}
-Function fpc_PWideChar_To_ShortStr(const p : pwidechar): shortstring; compilerproc;
-var
- Size : SizeInt;
- temp: ansistring;
-begin
- result:='';
- if p=nil then
- exit;
- Size := IndexWord(p^, $7fffffff, 0);
- if Size>0 then
- begin
- widestringmanager.Wide2AnsiMoveProc(p,temp,Size);
- result:=temp;
- end;
-end;
-{$else FPC_STRTOSHORTSTRINGPROC}
-procedure fpc_PWideChar_To_ShortStr(out res : shortstring;const p : pwidechar); compilerproc;
-var
- Size : SizeInt;
- temp: ansistring;
-begin
- res:='';
- if p=nil then
- exit;
- Size:=IndexWord(p^, high(PtrInt), 0);
- if Size>0 then
- begin
- widestringmanager.Wide2AnsiMoveProc(p,temp,Size);
- res:=temp;
- end;
-end;
-{$endif FPC_STRTOSHORTSTRINGPROC}
-
-
-{ checked against the ansistring routine, 2001-05-27 (FK) }
-Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[Public,Alias:'FPC_WIDESTR_ASSIGN']; compilerproc;
-{
- Assigns S2 to S1 (S1:=S2), taking in account reference counts.
-}
-begin
-{$ifdef FPC_WINLIKEWIDESTRING}
- if S1=S2 then exit;
- if S2<>nil then
- begin
- 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
- 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
- inclocked(PWideRec(S2-WideFirstOff)^.ref);
- { Decrease the reference count on the old S1 }
- fpc_widestr_decr_ref (S1);
- s1:=s2;
-{$endif FPC_WINLIKEWIDESTRING}
-end;
-
-
-{ alias for internal use }
-Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[external name 'FPC_WIDESTR_ASSIGN'];
-
-{$ifndef STR_CONCAT_PROCS}
-
-function fpc_WideStr_Concat (const S1,S2 : WideString): WideString; compilerproc;
-Var
- Size,Location : SizeInt;
- pc : pwidechar;
-begin
- { only assign if s1 or s2 is empty }
- if (S1='') then
- begin
- result:=s2;
- exit;
- end;
- if (S2='') then
- begin
- result:=s1;
- exit;
- end;
- Location:=Length(S1);
- Size:=length(S2);
- SetLength(result,Size+Location);
- pc:=pwidechar(result);
- Move(S1[1],pc^,Location*sizeof(WideChar));
- inc(pc,location);
- Move(S2[1],pc^,(Size+1)*sizeof(WideChar));
-end;
-
-
-function fpc_WideStr_Concat_multi (const sarr:array of Widestring): widestring; compilerproc;
-Var
- i : Longint;
- p : pointer;
- pc : pwidechar;
- Size,NewSize : SizeInt;
-begin
- { First calculate size of the result so we can do
- a single call to SetLength() }
- NewSize:=0;
- for i:=low(sarr) to high(sarr) do
- inc(Newsize,length(sarr[i]));
- SetLength(result,NewSize);
- pc:=pwidechar(result);
- for i:=low(sarr) to high(sarr) do
- begin
- p:=pointer(sarr[i]);
- if assigned(p) then
- begin
- Size:=length(widestring(p));
- Move(pwidechar(p)^,pc^,(Size+1)*sizeof(WideChar));
- inc(pc,size);
- end;
- end;
-end;
-
-{$else STR_CONCAT_PROCS}
-
-procedure fpc_WideStr_Concat (var DestS:Widestring;const S1,S2 : WideString); compilerproc;
-Var
- Size,Location : SizeInt;
- same : boolean;
-begin
- { only assign if s1 or s2 is empty }
- if (S1='') then
- begin
- DestS:=s2;
- exit;
- end;
- if (S2='') then
- begin
- DestS:=s1;
- exit;
- end;
- Location:=Length(S1);
- Size:=length(S2);
- { Use Pointer() typecasts to prevent extra conversion code }
- if Pointer(DestS)=Pointer(S1) then
- begin
- same:=Pointer(S1)=Pointer(S2);
- SetLength(DestS,Size+Location);
- if same then
- Move(Pointer(DestS)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size)*sizeof(WideChar))
- else
- Move(Pointer(S2)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
- end
- else if Pointer(DestS)=Pointer(S2) then
- begin
- SetLength(DestS,Size+Location);
- Move(Pointer(DestS)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
- Move(Pointer(S1)^,Pointer(DestS)^,Location*sizeof(WideChar));
- end
- else
- begin
- DestS:='';
- SetLength(DestS,Size+Location);
- Move(Pointer(S1)^,Pointer(DestS)^,Location*sizeof(WideChar));
- Move(Pointer(S2)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
- end;
-end;
-
-
-procedure fpc_WideStr_Concat_multi (var DestS:Widestring;const sarr:array of Widestring); compilerproc;
-Var
- i : Longint;
- p,pc : pointer;
- Size,NewLen : SizeInt;
-{$ifndef FPC_WINLIKEWIDESTRING}
- lowstart : longint;
- destcopy : pointer;
- OldDestLen : SizeInt;
-{$else FPC_WINLIKEWIDESTRING}
- DestTmp : Widestring;
-{$endif FPC_WINLIKEWIDESTRING}
-begin
- if high(sarr)=0 then
- begin
- DestS:='';
- exit;
- end;
-{$ifndef FPC_WINLIKEWIDESTRING}
- destcopy:=nil;
- lowstart:=low(sarr);
- if Pointer(DestS)=Pointer(sarr[lowstart]) then
- inc(lowstart);
- { Check for another reuse, then we can't use
- the append optimization }
- for i:=lowstart to high(sarr) do
- begin
- if Pointer(DestS)=Pointer(sarr[i]) then
- begin
- { if DestS is used somewhere in the middle of the expression,
- we need to make sure the original string still exists after
- we empty/modify DestS.
- This trick only works with reference counted strings. Therefor
- this optimization is disabled for WINLIKEWIDESTRING }
- destcopy:=pointer(dests);
- fpc_WideStr_Incr_Ref(destcopy);
- lowstart:=low(sarr);
- break;
- end;
- end;
- { Start with empty DestS if we start with concatting
- the first array element }
- if lowstart=low(sarr) then
- DestS:='';
- OldDestLen:=length(DestS);
- { Calculate size of the result so we can do
- a single call to SetLength() }
- NewLen:=0;
- for i:=low(sarr) to high(sarr) do
- inc(NewLen,length(sarr[i]));
- SetLength(DestS,NewLen);
- { Concat all strings, except the string we already
- copied in DestS }
- pc:=Pointer(DestS)+OldDestLen*sizeof(WideChar);
- for i:=lowstart to high(sarr) do
- begin
- p:=pointer(sarr[i]);
- if assigned(p) then
- begin
- Size:=length(widestring(p));
- Move(p^,pc^,(Size+1)*sizeof(WideChar));
- inc(pc,size*sizeof(WideChar));
- end;
- end;
- fpc_WideStr_Decr_Ref(destcopy);
-{$else FPC_WINLIKEWIDESTRING}
- { First calculate size of the result so we can do
- a single call to SetLength() }
- NewLen:=0;
- for i:=low(sarr) to high(sarr) do
- inc(NewLen,length(sarr[i]));
- SetLength(DestTmp,NewLen);
- pc:=pwidechar(DestTmp);
- for i:=low(sarr) to high(sarr) do
- begin
- p:=pointer(sarr[i]);
- if assigned(p) then
- begin
- Size:=length(widestring(p));
- Move(p^,pc^,(Size+1)*sizeof(WideChar));
- inc(pc,size*sizeof(WideChar));
- end;
- end;
- DestS:=DestTmp;
-{$endif FPC_WINLIKEWIDESTRING}
-end;
-
-{$endif STR_CONCAT_PROCS}
-
-Function fpc_Char_To_WChar(const c : Char): WideChar; compilerproc;
-var
- w: widestring;
-begin
- widestringmanager.Ansi2WideMoveProc(@c, w, 1);
- fpc_Char_To_WChar:= w[1];
-end;
-
-
-
-Function fpc_Char_To_WideStr(const c : Char): WideString; compilerproc;
-{
- Converts a Char to a WideString;
-}
-begin
- Setlength(fpc_Char_To_WideStr,1);
- fpc_Char_To_WideStr[1]:=c;
- { Terminating Zero }
- PWideChar(Pointer(fpc_Char_To_WideStr)+sizeof(WideChar))^:=#0;
-end;
-
-
-Function fpc_WChar_To_Char(const c : WideChar): Char; compilerproc;
-{
- Converts a WideChar to a Char;
-}
-var
- s: ansistring;
-begin
- widestringmanager.Wide2AnsiMoveProc(@c, s, 1);
- if length(s)=1 then
- fpc_WChar_To_Char:= s[1]
- else
- fpc_WChar_To_Char:='?';
-end;
-
-
-Function fpc_WChar_To_WideStr(const c : WideChar): WideString; compilerproc;
-{
- Converts a WideChar to a WideString;
-}
-begin
- Setlength (fpc_WChar_To_WideStr,1);
- fpc_WChar_To_WideStr[1]:= c;
-end;
-
-
-Function fpc_WChar_To_AnsiStr(const c : WideChar): AnsiString; compilerproc;
-{
- Converts a WideChar to a AnsiString;
-}
-begin
- widestringmanager.Wide2AnsiMoveProc(@c, fpc_WChar_To_AnsiStr, 1);
-end;
-
-
-{$ifndef FPC_STRTOSHORTSTRINGPROC}
-Function fpc_WChar_To_ShortStr(const c : WideChar): ShortString; compilerproc;
-{
- Converts a WideChar to a ShortString;
-}
-var
- s: ansistring;
-begin
- widestringmanager.Wide2AnsiMoveProc(@c, s, 1);
- fpc_WChar_To_ShortStr:= s;
-end;
-{$else FPC_STRTOSHORTSTRINGPROC}
-procedure fpc_WChar_To_ShortStr(out res : shortstring;const c : WideChar) compilerproc;
-{
- Converts a WideChar to a ShortString;
-}
-var
- s: ansistring;
-begin
- widestringmanager.Wide2AnsiMoveProc(@c,s,1);
- res:=s;
-end;
-{$endif FPC_STRTOSHORTSTRINGPROC}
-
-
-Function fpc_PChar_To_WideStr(const p : pchar): WideString; compilerproc;
-Var
- L : SizeInt;
-begin
- if (not assigned(p)) or (p[0]=#0) Then
- begin
- fpc_pchar_to_widestr := '';
- exit;
- end;
- l:=IndexChar(p^,-1,#0);
- widestringmanager.Ansi2WideMoveProc(P,fpc_PChar_To_WideStr,l);
-end;
-
-
-Function fpc_CharArray_To_WideStr(const arr: array of char; zerobased: boolean = true): WideString; compilerproc;
-var
- i : SizeInt;
-begin
- if (zerobased) then
- begin
- if (arr[0]=#0) Then
- begin
- fpc_chararray_to_widestr := '';
- exit;
- end;
- i:=IndexChar(arr,high(arr)+1,#0);
- if i = -1 then
- i := high(arr)+1;
- end
- else
- i := high(arr)+1;
- SetLength(fpc_CharArray_To_WideStr,i);
- widestringmanager.Ansi2WideMoveProc (pchar(@arr),fpc_CharArray_To_WideStr,i);
-end;
-
-
-{$ifndef FPC_STRTOSHORTSTRINGPROC}
-function fpc_WideCharArray_To_ShortStr(const arr: array of widechar; zerobased: boolean = true): shortstring;[public,alias:'FPC_WIDECHARARRAY_TO_SHORTSTR']; compilerproc;
-var
- l: longint;
- index: longint;
- len: byte;
- temp: ansistring;
-begin
- l := high(arr)+1;
- if l>=256 then
- l:=255
- else if l<0 then
- l:=0;
- if zerobased then
- begin
- index:=IndexWord(arr[0],l,0);
- if (index < 0) then
- len := l
- else
- len := index;
- end
- else
- len := l;
- widestringmanager.Wide2AnsiMoveProc (pwidechar(@arr),temp,len);
- fpc_WideCharArray_To_ShortStr := temp;
-end;
-{$else FPC_STRTOSHORTSTRINGPROC}
-procedure fpc_WideCharArray_To_ShortStr(out res : shortstring;const arr: array of widechar; zerobased: boolean = true);[public,alias:'FPC_WIDECHARARRAY_TO_SHORTSTR']; compilerproc;
-var
- l: longint;
- index: ptrint;
- len: byte;
- temp: ansistring;
-begin
- l := high(arr)+1;
- if l>=high(res)+1 then
- l:=high(res)
- else if l<0 then
- l:=0;
- if zerobased then
- begin
- index:=IndexWord(arr[0],l,0);
- if index<0 then
- len:=l
- else
- len:=index;
- end
- else
- len:=l;
- widestringmanager.Wide2AnsiMoveProc (pwidechar(@arr),temp,len);
- res:=temp;
-end;
-{$endif FPC_STRTOSHORTSTRINGPROC}
-
-Function fpc_WideCharArray_To_AnsiStr(const arr: array of widechar; zerobased: boolean = true): AnsiString; compilerproc;
-var
- i : SizeInt;
-begin
- if (zerobased) then
- begin
- i:=IndexWord(arr,high(arr)+1,0);
- if i = -1 then
- i := high(arr)+1;
- end
- else
- i := high(arr)+1;
- SetLength(fpc_WideCharArray_To_AnsiStr,i);
- widestringmanager.Wide2AnsiMoveProc (pwidechar(@arr),fpc_WideCharArray_To_AnsiStr,i);
-end;
-
-Function fpc_WideCharArray_To_WideStr(const arr: array of widechar; zerobased: boolean = true): WideString; compilerproc;
-var
- i : SizeInt;
-begin
- if (zerobased) then
- begin
- i:=IndexWord(arr,high(arr)+1,0);
- if i = -1 then
- i := high(arr)+1;
- end
- else
- i := high(arr)+1;
- SetLength(fpc_WideCharArray_To_WideStr,i);
- Move(arr[0], Pointer(fpc_WideCharArray_To_WideStr)^,i*sizeof(WideChar));
-end;
-
-{$ifndef FPC_STRTOCHARARRAYPROC}
-
-{ inside the compiler, the resulttype is modified to that of the actual }
-{ chararray we're converting to (JM) }
-function fpc_widestr_to_chararray(arraysize: SizeInt; const src: WideString): fpc_big_chararray;[public,alias: 'FPC_WIDESTR_TO_CHARARRAY']; compilerproc;
-var
- len: SizeInt;
- temp: ansistring;
-begin
- len := length(src);
- { make sure we don't dereference src if it can be nil (JM) }
- if len > 0 then
- widestringmanager.wide2ansimoveproc(pwidechar(@src[1]),temp,len);
- len := length(temp);
- if len > arraysize then
- len := arraysize;
-{$r-}
- move(temp[1],fpc_widestr_to_chararray[0],len);
- fillchar(fpc_widestr_to_chararray[len],arraysize-len,0);
-{$ifdef RangeCheckWasOn}
-{$r+}
-{$endif}
-end;
-
-
-{ inside the compiler, the resulttype is modified to that of the actual }
-{ widechararray we're converting to (JM) }
-function fpc_widestr_to_widechararray(arraysize: SizeInt; const src: WideString): fpc_big_widechararray;[public,alias: 'FPC_WIDESTR_TO_WIDECHARARRAY']; compilerproc;
-var
- len: SizeInt;
-begin
- len := length(src);
- if len > arraysize then
- len := arraysize;
-{$r-}
- { make sure we don't try to access element 1 of the ansistring if it's nil }
- if len > 0 then
- move(src[1],fpc_widestr_to_widechararray[0],len*SizeOf(WideChar));
- fillchar(fpc_widestr_to_widechararray[len],(arraysize-len)*SizeOf(WideChar),0);
-{$ifdef RangeCheckWasOn}
-{$r+}
-{$endif}
-end;
-
-
-{ inside the compiler, the resulttype is modified to that of the actual }
-{ chararray we're converting to (JM) }
-function fpc_ansistr_to_widechararray(arraysize: SizeInt; const src: AnsiString): fpc_big_widechararray;[public,alias: 'FPC_ANSISTR_TO_WIDECHARARRAY']; compilerproc;
-var
- len: SizeInt;
- temp: widestring;
-begin
- len := length(src);
- { make sure we don't dereference src if it can be nil (JM) }
- if len > 0 then
- widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
- len := length(temp);
- if len > arraysize then
- len := arraysize;
-
-{$r-}
- move(temp[1],fpc_ansistr_to_widechararray[0],len*sizeof(widechar));
- fillchar(fpc_ansistr_to_widechararray[len],(arraysize-len)*SizeOf(WideChar),0);
-{$ifdef RangeCheckWasOn}
-{$r+}
-{$endif}
-end;
-
-function fpc_shortstr_to_widechararray(arraysize: SizeInt; const src: ShortString): fpc_big_widechararray;[public,alias: 'FPC_SHORTSTR_TO_WIDECHARARRAY']; compilerproc;
-var
- len: longint;
- temp : widestring;
-begin
- len := length(src);
- { make sure we don't access char 1 if length is 0 (JM) }
- if len > 0 then
- widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
- len := length(temp);
- if len > arraysize then
- len := arraysize;
-{$r-}
- move(temp[1],fpc_shortstr_to_widechararray[0],len*sizeof(widechar));
- fillchar(fpc_shortstr_to_widechararray[len],(arraysize-len)*SizeOf(WideChar),0);
-{$ifdef RangeCheckWasOn}
-{$r+}
-{$endif}
-end;
-
-{$else ndef FPC_STRTOCHARARRAYPROC}
-
-procedure fpc_widestr_to_chararray(out res: array of char; const src: WideString); compilerproc;
-var
- len: SizeInt;
- temp: ansistring;
-begin
- len := length(src);
- { make sure we don't dereference src if it can be nil (JM) }
- if len > 0 then
- widestringmanager.wide2ansimoveproc(pwidechar(@src[1]),temp,len);
- len := length(temp);
- if len > length(res) then
- len := length(res);
-{$r-}
- move(temp[1],res[0],len);
- fillchar(res[len],length(res)-len,0);
-{$ifdef RangeCheckWasOn}
-{$r+}
-{$endif}
-end;
-
-
-procedure fpc_widestr_to_widechararray(out res: array of widechar; const src: WideString); compilerproc;
-var
- len: SizeInt;
-begin
- len := length(src);
- if len > length(res) then
- len := length(res);
-{$r-}
- { make sure we don't try to access element 1 of the ansistring if it's nil }
- if len > 0 then
- move(src[1],res[0],len*SizeOf(WideChar));
- fillchar(res[len],(length(res)-len)*SizeOf(WideChar),0);
-{$ifdef RangeCheckWasOn}
-{$r+}
-{$endif}
-end;
-
-
-procedure fpc_ansistr_to_widechararray(out res: array of widechar; const src: AnsiString); compilerproc;
-var
- len: SizeInt;
- temp: widestring;
-begin
- len := length(src);
- { make sure we don't dereference src if it can be nil (JM) }
- if len > 0 then
- widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
- len := length(temp);
- if len > length(res) then
- len := length(res);
-
-{$r-}
- move(temp[1],res[0],len*sizeof(widechar));
- fillchar(res[len],(length(res)-len)*SizeOf(WideChar),0);
-{$ifdef RangeCheckWasOn}
-{$r+}
-{$endif}
-end;
-
-procedure fpc_shortstr_to_widechararray(out res: array of widechar; const src: ShortString); compilerproc;
-var
- len: longint;
- temp : widestring;
-begin
- len := length(src);
- { make sure we don't access char 1 if length is 0 (JM) }
- if len > 0 then
- widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
- len := length(temp);
- if len > length(res) then
- len := length(res);
-{$r-}
- move(temp[1],res[0],len*sizeof(widechar));
- fillchar(res[len],(length(res)-len)*SizeOf(WideChar),0);
-{$ifdef RangeCheckWasOn}
-{$r+}
-{$endif}
-end;
-
-{$endif ndef FPC_STRTOCHARARRAYPROC}
-
-Function fpc_WideStr_Compare(const S1,S2 : WideString): SizeInt;[Public,Alias : 'FPC_WIDESTR_COMPARE']; compilerproc;
-{
- Compares 2 WideStrings;
- The result is
- <0 if S1<S2
- 0 if S1=S2
- >0 if S1>S2
-}
-Var
- MaxI,Temp : SizeInt;
-begin
- if pointer(S1)=pointer(S2) then
- begin
- fpc_WideStr_Compare:=0;
- exit;
- end;
- Maxi:=Length(S1);
- temp:=Length(S2);
- If MaxI>Temp then
- MaxI:=Temp;
- Temp:=CompareWord(S1[1],S2[1],MaxI);
- if temp=0 then
- temp:=Length(S1)-Length(S2);
- fpc_WideStr_Compare:=Temp;
-end;
-
-Function fpc_WideStr_Compare_Equal(const S1,S2 : WideString): SizeInt;[Public,Alias : 'FPC_WIDESTR_COMPARE_EQUAL']; compilerproc;
-{
- Compares 2 WideStrings for equality only;
- The result is
- 0 if S1=S2
- <>0 if S1<>S2
-}
-Var
- MaxI : SizeInt;
-begin
- if pointer(S1)=pointer(S2) then
- exit(0);
- Maxi:=Length(S1);
- If MaxI<>Length(S2) then
- exit(-1)
- else
- exit(CompareWord(S1[1],S2[1],MaxI));
-end;
-
-Procedure fpc_WideStr_CheckZero(p : pointer);[Public,Alias : 'FPC_WIDESTR_CHECKZERO']; compilerproc;
-begin
- if p=nil then
- HandleErrorFrame(201,get_frame);
-end;
-
-
-Procedure fpc_WideStr_CheckRange(len,index : SizeInt);[Public,Alias : 'FPC_WIDESTR_RANGECHECK']; compilerproc;
-begin
- if (index>len div 2) or (Index<1) then
- HandleErrorFrame(201,get_frame);
-end;
-
-Procedure fpc_WideStr_SetLength(Var S : WideString; l : SizeInt);[Public,Alias : 'FPC_WIDESTR_SETLENGTH']; compilerproc;
-{
- Sets The length of string S to L.
- Makes sure S is unique, and contains enough room.
-}
-Var
- Temp : Pointer;
- movelen: SizeInt;
-begin
- if (l>0) then
- begin
- if Pointer(S)=nil then
- begin
- { Need a complete new string...}
- Pointer(s):=NewWideString(l);
- end
- { windows doesn't support reallocing widestrings, this code
- is anyways subject to be removed because widestrings shouldn't be
- ref. counted anymore (FK) }
- else
- if
-{$ifdef MSWINDOWS}
- not winwidestringalloc and
-{$endif MSWINDOWS}
-{$ifdef FPC_WINLIKEWIDESTRING}
- not IsWideStringConstant(pointer(S))
-{$else}
- (PWideRec(Pointer(S)-WideFirstOff)^.Ref = 1)
-{$endif FPC_WINLIKEWIDESTRING}
- then
- begin
- Dec(Pointer(S),WideFirstOff);
- if SizeUInt(L*sizeof(WideChar)+WideRecLen)>MemSize(Pointer(S)) then
- reallocmem(pointer(S), L*sizeof(WideChar)+WideRecLen);
- Inc(Pointer(S), WideFirstOff);
- end
- else
- begin
- { Reallocation is needed... }
- Temp:=Pointer(NewWideString(L));
- if Length(S)>0 then
- begin
- if l < succ(length(s)) then
- movelen := l
- { also move terminating null }
- else
- movelen := succ(length(s));
- Move(Pointer(S)^,Temp^,movelen * Sizeof(WideChar));
- end;
- fpc_widestr_decr_ref(Pointer(S));
- Pointer(S):=Temp;
- end;
- { Force nil termination in case it gets shorter }
- PWord(Pointer(S)+l*sizeof(WideChar))^:=0;
-{$ifdef MSWINDOWS}
- if not winwidestringalloc then
-{$endif MSWINDOWS}
- PWideRec(Pointer(S)-WideFirstOff)^.Len:=l*sizeof(WideChar);
- 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.
-*****************************************************************************}
-
-function WideCharToString(S : PWideChar) : AnsiString;
- begin
- result:=WideCharLenToString(s,Length(WideString(s)));
- end;
-
-function StringToWideChar(const Src : AnsiString;Dest : PWideChar;DestSize : SizeInt) : PWideChar;
- var
- temp:widestring;
- begin
- widestringmanager.Ansi2WideMoveProc(PChar(Src),temp,Length(Src));
- if Length(temp)<DestSize then
- move(temp[1],Dest^,Length(temp)*SizeOf(WideChar))
- else
- move(temp[1],Dest^,(DestSize-1)*SizeOf(WideChar));
-
- Dest[DestSize-1]:=#0;
-
- result:=Dest;
-
- end;
-
-function WideCharLenToString(S : PWideChar;Len : SizeInt) : AnsiString;
- begin
- //SetLength(result,Len);
- widestringmanager.Wide2AnsiMoveproc(S,result,Len);
- end;
-
-procedure WideCharLenToStrVar(Src : PWideChar;Len : SizeInt;out Dest : AnsiString);
- begin
- Dest:=WideCharLenToString(Src,Len);
- end;
-
-procedure WideCharToStrVar(S : PWideChar;out Dest : AnsiString);
- begin
- Dest:=WideCharToString(S);
- end;
-
-
-Function fpc_widestr_Unique(Var S : Pointer): Pointer; [Public,Alias : 'FPC_WIDESTR_UNIQUE']; compilerproc;
-{$ifdef FPC_WINLIKEWIDESTRING}
- begin
- pointer(result) := pointer(s);
- end;
-{$else FPC_WINLIKEWIDESTRING}
-{
- Make sure reference count of S is 1,
- using copy-on-write semantics.
-}
-Var
- SNew : Pointer;
- L : SizeInt;
-begin
- pointer(result) := pointer(s);
- If Pointer(S)=Nil then
- exit;
- if PWideRec(Pointer(S)-WideFirstOff)^.Ref<>1 then
- begin
- L:=PWideRec(Pointer(S)-WideFirstOff)^.len div sizeof(WideChar);
- SNew:=NewWideString (L);
- Move (PWideChar(S)^,SNew^,(L+1)*sizeof(WideChar));
- PWideRec(SNew-WideFirstOff)^.len:=L * sizeof(WideChar);
- fpc_widestr_decr_ref (Pointer(S)); { Thread safe }
- pointer(S):=SNew;
- pointer(result):=SNew;
- end;
-end;
-{$endif FPC_WINLIKEWIDESTRING}
-
-
-Function Fpc_WideStr_Copy (Const S : WideString; Index,Size : SizeInt) : WideString;compilerproc;
-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*sizeof(WideChar);
- PWideChar(ResultAddress+Size*sizeof(WideChar))^:=#0;
- end;
- end;
- fpc_widestr_decr_ref(Pointer(fpc_widestr_copy));
- Pointer(fpc_widestr_Copy):=ResultAddress;
-end;
-
-
-Function Pos (Const Substr : WideString; Const Source : WideString) : SizeInt;
-var
- i,MaxLen : SizeInt;
- 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) : SizeInt;
-var
- i: SizeInt;
- 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;
-
-
-Function Pos (c : WideChar; Const s : AnsiString) : SizeInt;
- begin
- result:=Pos(c,WideString(s));
- end;
-
-
-Function Pos (c : AnsiString; Const s : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
- begin
- result:=Pos(WideString(c),s);
- end;
-
-
-Function Pos (c : ShortString; Const s : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
- begin
- result:=Pos(WideString(c),s);
- end;
-
-
-Function Pos (c : WideString; Const s : AnsiString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
- begin
- result:=Pos(c,WideString(s));
- 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) : SizeInt;
-var
- i: SizeInt;
- 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: SizeInt);
-Var
- LS : SizeInt;
-begin
- If Length(S)=0 then
- exit;
- if index<=0 then
- exit;
- LS:=PWideRec(Pointer(S)-WideFirstOff)^.Len div sizeof(WideChar);
- 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-Size+1)*sizeof(WideChar));
- end;
- Setlength(s,LS-Size);
- end;
-end;
-
-
-Procedure Insert (Const Source : WideString; Var S : WideString; Index : SizeInt);
-var
- Temp : WideString;
- LS : SizeInt;
-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;
-
-
-function UpCase(const s : WideString) : WideString;
-begin
- result:=widestringmanager.UpperWideStringProc(s);
-end;
-
-
-Procedure SetString (Out S : WideString; Buf : PWideChar; Len : SizeInt);
-var
- BufLen: SizeInt;
-begin
- SetLength(S,Len);
- If (Buf<>Nil) and (Len>0) then
- begin
- BufLen := IndexWord(Buf^, Len+1, 0);
- If (BufLen>0) and (BufLen < Len) then
- Len := BufLen;
- Move (Buf[0],S[1],Len*sizeof(WideChar));
- PWideChar(Pointer(S)+Len*sizeof(WideChar))^:=#0;
- end;
-end;
-
-
-Procedure SetString (Out S : WideString; Buf : PChar; Len : SizeInt);
-var
- BufLen: SizeInt;
-begin
- SetLength(S,Len);
- If (Buf<>Nil) and (Len>0) then
- begin
- BufLen := IndexByte(Buf^, Len+1, 0);
- If (BufLen>0) and (BufLen < Len) then
- Len := BufLen;
- widestringmanager.Ansi2WideMoveProc(Buf,S,Len);
- //PWideChar(Pointer(S)+Len*sizeof(WideChar))^:=#0;
- end;
-end;
-
-
-{$ifndef FPUNONE}
-Function fpc_Val_Real_WideStr(Const S : WideString; out Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_WIDESTR']; compilerproc;
-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;
-{$endif}
-
-function fpc_val_enum_widestr(str2ordindex:pointer;const s:widestring;out code:valsint):longint;compilerproc;
-
-var ss:shortstring;
-
-begin
- if length(s)>255 then
- code:=256
- else
- begin
- ss:=s;
- val(ss,fpc_val_enum_widestr,code);
- end;
-end;
-
-Function fpc_Val_Currency_WideStr(Const S : WideString; out Code : ValSInt): Currency; [public, alias:'FPC_VAL_CURRENCY_WIDESTR']; compilerproc;
-Var
- SS : String;
-begin
- if length(S) > 255 then
- begin
- fpc_Val_Currency_WideStr:=0;
- code := 256;
- end
- else
- begin
- SS := S;
- Val(SS,fpc_Val_Currency_WideStr,code);
- end;
-end;
-
-
-Function fpc_Val_UInt_WideStr (Const S : WideString; out Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_WIDESTR']; compilerproc;
-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: SizeInt; Const S : WideString; out Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_WIDESTR']; compilerproc;
-Var
- SS : ShortString;
-begin
- fpc_Val_SInt_WideStr:=0;
- if length(S)>255 then
- code:=256
- else
- begin
- SS := S;
- fpc_Val_SInt_WideStr := int_Val_SInt_ShortStr(DestSize,SS,Code);
- end;
-end;
-
-
-{$ifndef CPU64}
-
-Function fpc_Val_qword_WideStr (Const S : WideString; out Code : ValSInt): qword; [public, alias:'FPC_VAL_QWORD_WIDESTR']; compilerproc;
-Var
- SS : ShortString;
-begin
- fpc_Val_qword_WideStr:=0;
- if length(S)>255 then
- code:=256
- else
- begin
- SS := S;
- Val(SS,fpc_Val_qword_WideStr,Code);
- end;
-end;
-
-
-Function fpc_Val_int64_WideStr (Const S : WideString; out Code : ValSInt): Int64; [public, alias:'FPC_VAL_INT64_WIDESTR']; compilerproc;
-Var
- SS : ShortString;
-begin
- fpc_Val_int64_WideStr:=0;
- if length(S)>255 then
- code:=256
- else
- begin
- SS := S;
- Val(SS,fpc_Val_int64_WideStr,Code);
- end;
-end;
-
-{$endif CPU64}
-
-
-{$ifndef FPUNONE}
-procedure fpc_WideStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : WideString);compilerproc;
-var
- ss : shortstring;
-begin
- str_real(len,fr,d,treal_type(rt),ss);
- s:=ss;
-end;
-{$endif}
-
-procedure fpc_widestr_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:widestring);compilerproc;
-
-var ss:shortstring;
-
-begin
- fpc_shortstr_enum(ordinal,len,typinfo,ord2strindex,ss);
- s:=ss;
-end;
-
-{$ifdef FPC_HAS_STR_CURRENCY}
-procedure fpc_WideStr_Currency(c : Currency;len,fr : SizeInt;out s : WideString);compilerproc;
-var
- ss : shortstring;
-begin
- str(c:len:fr,ss);
- s:=ss;
-end;
-{$endif FPC_HAS_STR_CURRENCY}
-
-Procedure fpc_WideStr_SInt(v : ValSint; Len : SizeInt; out S : WideString);compilerproc;
-Var
- SS : ShortString;
-begin
- Str (v:Len,SS);
- S:=SS;
-end;
-
-
-Procedure fpc_WideStr_UInt(v : ValUInt;Len : SizeInt; out S : WideString);compilerproc;
-Var
- SS : ShortString;
-begin
- str(v:Len,SS);
- S:=SS;
-end;
-
-
-{$ifndef CPU64}
-
-Procedure fpc_WideStr_Int64(v : Int64; Len : SizeInt; out S : WideString);compilerproc;
-Var
- SS : ShortString;
-begin
- Str (v:Len,SS);
- S:=SS;
-end;
-
-
-Procedure fpc_WideStr_Qword(v : Qword;Len : SizeInt; out S : WideString);compilerproc;
-Var
- SS : ShortString;
-begin
- str(v:Len,SS);
- S:=SS;
-end;
-
-{$endif CPU64}
-
-function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
- begin
- if assigned(Source) then
- Result:=UnicodeToUtf8(Dest,MaxBytes,Source,IndexWord(Source^,-1,0))
- else
- Result:=0;
- end;
-
-
-function UnicodeToUtf8(Dest: PChar; MaxDestBytes: SizeUInt; Source: PWideChar; SourceChars: SizeUInt): SizeUInt;
- var
- i,j : SizeUInt;
- w : word;
- begin
- result:=0;
- if source=nil then
- exit;
- i:=0;
- j:=0;
- if assigned(Dest) then
- begin
- while (i<SourceChars) and (j<MaxDestBytes) do
- begin
- w:=word(Source[i]);
- case w of
- 0..$7f:
- begin
- Dest[j]:=char(w);
- inc(j);
- end;
- $80..$7ff:
- begin
- if j+1>=MaxDestBytes then
- break;
- Dest[j]:=char($c0 or (w shr 6));
- Dest[j+1]:=char($80 or (w and $3f));
- inc(j,2);
- end;
- else
- begin
- if j+2>=MaxDestBytes then
- break;
- Dest[j]:=char($e0 or (w shr 12));
- Dest[j+1]:=char($80 or ((w shr 6)and $3f));
- Dest[j+2]:=char($80 or (w and $3f));
- inc(j,3);
- end;
- end;
- inc(i);
- end;
-
- if j>SizeUInt(MaxDestBytes-1) then
- j:=MaxDestBytes-1;
-
- Dest[j]:=#0;
- end
- else
- begin
- while i<SourceChars do
- begin
- case word(Source[i]) of
- $0..$7f:
- inc(j);
- $80..$7ff:
- inc(j,2);
- else
- inc(j,3);
- end;
- inc(i);
- end;
- end;
- result:=j+1;
- end;
-
-
-function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
- begin
- if assigned(Source) then
- Result:=Utf8ToUnicode(Dest,MaxChars,Source,strlen(Source))
- else
- Result:=0;
- end;
-
-
-function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: SizeUInt; Source: PChar; SourceBytes: SizeUInt): SizeUInt;
-
-var
- i,j : SizeUInt;
- w: SizeUInt;
- b : byte;
-begin
- if not assigned(Source) then
- begin
- result:=0;
- exit;
- end;
- result:=SizeUInt(-1);
- i:=0;
- j:=0;
- if assigned(Dest) then
- begin
- while (j<MaxDestChars) and (i<SourceBytes) do
- begin
- b:=byte(Source[i]);
- w:=b;
- inc(i);
- // 2 or 3 bytes?
- if b>=$80 then
- begin
- w:=b and $3f;
- if i>=SourceBytes then
- exit;
- // 3 bytes?
- if (b and $20)<>0 then
- begin
- b:=byte(Source[i]);
- inc(i);
- if i>=SourceBytes then
- exit;
- if (b and $c0)<>$80 then
- exit;
- w:=(w shl 6) or (b and $3f);
- end;
- b:=byte(Source[i]);
- w:=(w shl 6) or (b and $3f);
- if (b and $c0)<>$80 then
- exit;
- inc(i);
- end;
- Dest[j]:=WideChar(w);
- inc(j);
- end;
- if j>=MaxDestChars then j:=MaxDestChars-1;
- Dest[j]:=#0;
- end
- else
- begin
- while i<SourceBytes do
- begin
- b:=byte(Source[i]);
- inc(i);
- // 2 or 3 bytes?
- if b>=$80 then
- begin
- if i>=SourceBytes then
- exit;
- // 3 bytes?
- b := b and $3f;
- if (b and $20)<>0 then
- begin
- b:=byte(Source[i]);
- inc(i);
- if i>=SourceBytes then
- exit;
- if (b and $c0)<>$80 then
- exit;
- end;
- if (byte(Source[i]) and $c0)<>$80 then
- exit;
- inc(i);
- end;
- inc(j);
- end;
- end;
- result:=j+1;
-end;
-
-
-function UTF8Encode(const s : WideString) : UTF8String;
- var
- i : SizeInt;
- hs : UTF8String;
- begin
- result:='';
- if s='' then
- exit;
- SetLength(hs,length(s)*3);
- i:=UnicodeToUtf8(pchar(hs),length(hs)+1,PWideChar(s),length(s));
- if i>0 then
- begin
- SetLength(hs,i-1);
- result:=hs;
- end;
- end;
-
-
-function UTF8Decode(const s : UTF8String): WideString;
- var
- i : SizeInt;
- hs : WideString;
- begin
- result:='';
- if s='' then
- exit;
- SetLength(hs,length(s));
- i:=Utf8ToUnicode(PWideChar(hs),length(hs)+1,pchar(s),length(s));
- if i>0 then
- begin
- SetLength(hs,i-1);
- result:=hs;
- end;
- end;
-
-
-function AnsiToUtf8(const s : ansistring): UTF8String;{$ifdef SYSTEMINLINE}inline;{$endif}
- begin
- Result:=Utf8Encode(s);
- end;
-
-
-function Utf8ToAnsi(const s : UTF8String) : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
- begin
- Result:=Utf8Decode(s);
- end;
-
-
-{ converts an utf-16 code point or surrogate pair to utf-32 }
-function utf16toutf32(const S: WideString; const index: SizeInt; out len: longint): UCS4Char; [public, alias: 'FPC_UTF16TOUTF32'];
-var
- w: widechar;
-begin
- { UTF-16 points in the range #$0-#$D7FF and #$E000-#$FFFF }
- { are the same in UTF-32 }
- w:=s[index];
- if (w<=#$d7ff) or
- (w>=#$e000) then
- begin
- result:=UCS4Char(w);
- len:=1;
- end
- { valid surrogate pair? }
- else if (w<=#$dbff) and
- { w>=#$d7ff check not needed, checked above }
- (index<length(s)) and
- (s[index+1]>=#$dc00) and
- (s[index+1]<=#$dfff) then
- { convert the surrogate pair to UTF-32 }
- begin
- result:=(UCS4Char(w)-$d800) shl 10 + (UCS4Char(s[index+1])-$dc00) + $10000;
- len:=2;
- end
- else
- { invalid surrogate -> do nothing }
- begin
- result:=UCS4Char(w);
- len:=1;
- end;
-end;
-
-
-function WideStringToUCS4String(const s : WideString) : UCS4String;
- var
- i, slen,
- destindex : SizeInt;
- len : longint;
- begin
- slen:=length(s);
- setlength(result,slen+1);
- i:=1;
- destindex:=0;
- while (i<=slen) do
- begin
- result[destindex]:=utf16toutf32(s,i,len);
- inc(destindex);
- inc(i,len);
- end;
- { destindex <= slen (surrogate pairs may have been merged) }
- { destindex+1 for terminating #0 (dynamic arrays are }
- { implicitely filled with zero) }
- setlength(result,destindex+1);
- end;
-
-
-{ concatenates an utf-32 char to a widestring. S *must* be unique when entering. }
-procedure ConcatUTF32ToWideStr(const nc: UCS4Char; var S: WideString; var index: SizeInt);
-var
- p : PWideChar;
-begin
- { if nc > $ffff, we need two places }
- if (index+ord(nc > $ffff)>length(s)) then
- if (length(s) < 10*256) then
- setlength(s,length(s)+10)
- else
- setlength(s,length(s)+length(s) shr 8);
- { we know that s is unique -> avoid uniquestring calls}
- p:=@s[index];
- if (nc<$ffff) then
- begin
- p^:=widechar(nc);
- inc(index);
- end
- else if (dword(nc)<=$10ffff) then
- begin
- p^:=widechar((nc - $10000) shr 10 + $d800);
- (p+1)^:=widechar((nc - $10000) and $3ff + $dc00);
- inc(index,2);
- end
- else
- { invalid code point }
- begin
- p^:='?';
- inc(index);
- end;
-end;
-
-
-function UCS4StringToWideString(const s : UCS4String) : WideString;
- var
- i : SizeInt;
- resindex : SizeInt;
- begin
- { skip terminating #0 }
- SetLength(result,length(s)-1);
- resindex:=1;
- for i:=0 to high(s)-1 do
- ConcatUTF32ToWideStr(s[i],result,resindex);
- { adjust result length (may be too big due to growing }
- { for surrogate pairs) }
- setlength(result,resindex-1);
- end;
-
-const
- SNoWidestrings = 'This binary has no widestrings support compiled in.';
- SRecompileWithWidestrings = 'Recompile the application with a widestrings-manager in the program uses clause.';
-
-procedure unimplementedwidestring;
- begin
-{$ifdef FPC_HAS_FEATURE_CONSOLEIO}
- If IsConsole then
- begin
- Writeln(StdErr,SNoWidestrings);
- Writeln(StdErr,SRecompileWithWidestrings);
- end;
-{$endif FPC_HAS_FEATURE_CONSOLEIO}
- HandleErrorFrame(233,get_frame);
- end;
-
-{$warnings off}
-function GenericWideCase(const s : WideString) : WideString;
- begin
- unimplementedwidestring;
- end;
-
-
-function CompareWideString(const s1, s2 : WideString) : PtrInt;
- begin
- unimplementedwidestring;
- end;
-
-
-function CompareTextWideString(const s1, s2 : WideString): PtrInt;
- begin
- unimplementedwidestring;
- end;
-
-
-function CharLengthPChar(const Str: PChar): PtrInt;
- begin
- unimplementedwidestring;
- end;
-{$warnings on}
-
-procedure initwidestringmanager;
- begin
- fillchar(widestringmanager,sizeof(widestringmanager),0);
-{$ifndef HAS_WIDESTRINGMANAGER}
- widestringmanager.Wide2AnsiMoveProc:=@defaultWide2AnsiMove;
- widestringmanager.Ansi2WideMoveProc:=@defaultAnsi2WideMove;
- widestringmanager.UpperWideStringProc:=@GenericWideCase;
- widestringmanager.LowerWideStringProc:=@GenericWideCase;
-{$endif HAS_WIDESTRINGMANAGER}
- widestringmanager.CompareWideStringProc:=@CompareWideString;
- widestringmanager.CompareTextWideStringProc:=@CompareTextWideString;
- widestringmanager.CharLengthPCharProc:=@CharLengthPChar;
- end;
diff --git a/rtl/linux/buildrtl.lpi b/rtl/linux/buildrtl.lpi
new file mode 100644
index 0000000000..b8bf886f03
--- /dev/null
+++ b/rtl/linux/buildrtl.lpi
@@ -0,0 +1,64 @@
+<?xml version="1.0"?>
+<CONFIG>
+ <ProjectOptions>
+ <PathDelim Value="/"/>
+ <Version Value="6"/>
+ <General>
+ <Flags>
+ <MainUnitHasUsesSectionForAllUnits Value="False"/>
+ <MainUnitHasCreateFormStatements Value="False"/>
+ <MainUnitHasTitleStatement Value="False"/>
+ <Runnable Value="False"/>
+ </Flags>
+ <SessionStorage Value="InProjectDir"/>
+ <MainUnit Value="0"/>
+ <IconPath Value="./"/>
+ <TargetFileExt Value=".exe"/>
+ <Title Value="buildrtl"/>
+ </General>
+ <VersionInfo>
+ <ProjectVersion Value=""/>
+ </VersionInfo>
+ <PublishOptions>
+ <Version Value="2"/>
+ <IgnoreBinaries Value="False"/>
+ <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+ <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
+ </PublishOptions>
+ <RunParams>
+ <local>
+ <FormatVersion Value="1"/>
+ <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+ </local>
+ </RunParams>
+ <Units Count="1">
+ <Unit0>
+ <Filename Value="buildrtl.pp"/>
+ <IsPartOfProject Value="True"/>
+ <UnitName Value="buildrtl"/>
+ </Unit0>
+ </Units>
+ </ProjectOptions>
+ <CompilerOptions>
+ <Version Value="8"/>
+ <SearchPaths>
+ <IncludeFiles Value="../inc/;../$(TargetCPU)/;../unix/;../objpas/classes/;../objpas/sysutils/;../objpas/"/>
+ <OtherUnitFiles Value="../objpas/;../objpas/classes/;../objpas/sysutils/;../inc/;../unix/;../$(TargetCPU)/"/>
+ <UnitOutputDirectory Value="../units/$(TargetCPU)-linux"/>
+ </SearchPaths>
+ <Parsing>
+ <Style Value="2"/>
+ </Parsing>
+ <Other>
+ <Verbosity>
+ <ShowNotes Value="False"/>
+ <ShowHints Value="False"/>
+ </Verbosity>
+ <CompilerPath Value="$(CompPath)"/>
+ <ExecuteBefore>
+ <Command Value="cmd.exe /c "if not exist ../units/$(TargetCPU)-linux mkdir ../units/$(TargetCPU)-linux""/>
+ <ShowAllMessages Value="True"/>
+ </ExecuteBefore>
+ </Other>
+ </CompilerOptions>
+</CONFIG>
diff --git a/rtl/linux/buildrtl.pp b/rtl/linux/buildrtl.pp
new file mode 100644
index 0000000000..80cae4c112
--- /dev/null
+++ b/rtl/linux/buildrtl.pp
@@ -0,0 +1,20 @@
+{ This unit is only used to edit the rtl with lazarus }
+unit buildrtl;
+
+ interface
+
+ uses
+ system, unixtype, ctypes, baseunix, strings, objpas,b macpas, syscall, unixutil,
+ fpintres, heaptrc, lineinfo, lnfodwrf,
+ termio, unix, linux, initc, cmem, mmx,
+ crt, printer, linuxvcs,
+ sysutils, typinfo, math, matrix, varutils,
+ charset, ucomplex, getopts,
+ errors, sockets, gpm, ipc, serial, terminfo, dl, dynlibs,
+ video, mouse, keyboard, variants, types, dateutils, sysconst, fmtbcd,
+ cthreads, classes, fgl, convutils, stdconvs, strutils, rtlconsts, dos, objects, cwstring, fpcylix, clocale,
+ exeinfo;
+
+ implementation
+
+end.
diff --git a/rtl/linux/system.pp b/rtl/linux/system.pp
index f472c44b2b..1532b8cb28 100644
--- a/rtl/linux/system.pp
+++ b/rtl/linux/system.pp
@@ -329,5 +329,9 @@ begin
{ threading }
InitSystemThreads;
initvariantmanager;
+{$ifdef VER2_2}
initwidestringmanager;
+{$else VER2_2}
+ initunicodestringmanager;
+{$endif VER2_2}
end.
diff --git a/rtl/objpas/classes/classes.inc b/rtl/objpas/classes/classes.inc
index 1a77ef75ff..7629204210 100644
--- a/rtl/objpas/classes/classes.inc
+++ b/rtl/objpas/classes/classes.inc
@@ -897,13 +897,16 @@ procedure ObjectBinaryToText(Input, Output: TStream);
end;
procedure OutString(s: String);
-
begin
OutChars(Pointer(S),PChar(S)+Length(S),@CharToOrd);
end;
procedure OutWString(W: WideString);
+ begin
+ OutChars(Pointer(W),pwidechar(W)+Length(W),@WideCharToOrd);
+ end;
+ procedure OutUString(W: UnicodeString);
begin
OutChars(Pointer(W),pwidechar(W)+Length(W),@WideCharToOrd);
end;
@@ -1047,6 +1050,25 @@ procedure ObjectBinaryToText(Input, Output: TStream);
end;
end;
+ function ReadUStr: UnicodeString;
+ var
+ len: DWord;
+ {$IFDEF ENDIAN_BIG}
+ i : integer;
+ {$ENDIF}
+ begin
+ len := ReadDWord;
+ SetLength(Result, len);
+ if (len > 0) then
+ begin
+ Input.ReadBuffer(Pointer(@Result[1])^, len*2);
+ {$IFDEF ENDIAN_BIG}
+ for i:=1 to len do
+ Result[i]:=widechar(SwapEndian(word(Result[i])));
+ {$ENDIF}
+ end;
+ end;
+
procedure ReadPropList(indent: String);
procedure ProcessValue(ValueType: TValueType; Indent: String);
@@ -1138,6 +1160,11 @@ procedure ObjectBinaryToText(Input, Output: TStream);
OutWString(ReadWStr);
OutLn('');
end;
+ vaUString:
+ begin
+ OutWString(ReadWStr);
+ OutLn('');
+ end;
vaNil:
OutLn('nil');
vaCollection: begin
diff --git a/rtl/objpas/classes/classesh.inc b/rtl/objpas/classes/classesh.inc
index 999d4065fd..2e2aa84d6f 100644
--- a/rtl/objpas/classes/classesh.inc
+++ b/rtl/objpas/classes/classesh.inc
@@ -901,7 +901,8 @@ type
TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended,
vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, vaLString,
- vaNil, vaCollection, vaSingle, vaCurrency, vaDate, vaWString, vaInt64, vaUTF8String);
+ vaNil, vaCollection, vaSingle, vaCurrency, vaDate, vaWString, vaInt64,
+ vaUTF8String, vaUString);
TFilerFlag = (ffInherited, ffChildPos, ffInline);
TFilerFlags = set of TFilerFlag;
@@ -967,6 +968,7 @@ type
function ReadStr: String; virtual; abstract;
function ReadString(StringType: TValueType): String; virtual; abstract;
function ReadWideString: WideString;virtual;abstract;
+ function ReadUnicodeString: UnicodeString;virtual;abstract;
procedure SkipComponent(SkipComponentInfos: Boolean); virtual; abstract;
procedure SkipValue; virtual; abstract;
end;
@@ -1018,6 +1020,7 @@ type
function ReadStr: String; override;
function ReadString(StringType: TValueType): String; override;
function ReadWideString: WideString;override;
+ function ReadUnicodeString: UnicodeString;override;
procedure SkipComponent(SkipComponentInfos: Boolean); override;
procedure SkipValue; override;
end;
@@ -1103,6 +1106,7 @@ type
function ReadBoolean: Boolean;
function ReadChar: Char;
function ReadWideChar: WideChar;
+ function ReadUnicodeChar: UnicodeChar;
procedure ReadCollection(Collection: TCollection);
function ReadComponent(Component: TComponent): TComponent;
procedure ReadComponents(AOwner, AParent: TComponent;
@@ -1121,6 +1125,7 @@ type
function ReadRootComponent(ARoot: TComponent): TComponent;
function ReadString: string;
function ReadWideString: WideString;
+ function ReadUnicodeString: UnicodeString;
function ReadValue: TValueType;
procedure CopyValue(Writer: TWriter);
property Driver: TAbstractObjectReader read FDriver;
@@ -1172,6 +1177,7 @@ type
procedure WriteSet(Value: LongInt; SetType: Pointer); virtual; abstract;
procedure WriteString(const Value: String); virtual; abstract;
procedure WriteWideString(const Value: WideString);virtual;abstract;
+ procedure WriteUnicodeString(const Value: UnicodeString);virtual;abstract;
end;
{ TBinaryObjectWriter }
@@ -1222,6 +1228,7 @@ type
procedure WriteSet(Value: LongInt; SetType: Pointer); override;
procedure WriteString(const Value: String); override;
procedure WriteWideString(const Value: WideString); override;
+ procedure WriteUnicodeString(const Value: UnicodeString); override;
end;
TTextObjectWriter = class(TAbstractObjectWriter)
@@ -1291,6 +1298,7 @@ type
procedure WriteRootComponent(ARoot: TComponent);
procedure WriteString(const Value: string);
procedure WriteWideString(const Value: WideString);
+ procedure WriteUnicodeString(const Value: UnicodeString);
property RootAncestor: TComponent read FRootAncestor write FRootAncestor;
property OnFindAncestor: TFindAncestorEvent read FOnFindAncestor write FOnFindAncestor;
property OnWriteMethodProperty: TWriteMethodPropertyEvent read FOnWriteMethodProperty write FOnWriteMethodProperty;
diff --git a/rtl/objpas/classes/reader.inc b/rtl/objpas/classes/reader.inc
index e33c2f7154..57f54cedda 100644
--- a/rtl/objpas/classes/reader.inc
+++ b/rtl/objpas/classes/reader.inc
@@ -339,6 +339,25 @@ begin
end;
end;
+function TBinaryObjectReader.ReadUnicodeString: UnicodeString;
+var
+ len: DWord;
+{$IFDEF ENDIAN_BIG}
+ i : integer;
+{$ENDIF}
+begin
+ len := ReadDWord;
+ SetLength(Result, len);
+ if (len > 0) then
+ begin
+ Read(Pointer(@Result[1])^, len*2);
+ {$IFDEF ENDIAN_BIG}
+ for i:=1 to len do
+ Result[i]:=UnicodeChar(SwapEndian(word(Result[i])));
+ {$ENDIF}
+ end;
+end;
+
procedure TBinaryObjectReader.SkipComponent(SkipComponentInfos: Boolean);
var
Flags: TFilerFlags;
@@ -409,6 +428,11 @@ begin
Count:=LongInt(ReadDWord);
SkipBytes(Count*sizeof(widechar));
end;
+ vaUString:
+ begin
+ Count:=LongInt(ReadDWord);
+ SkipBytes(Count*sizeof(widechar));
+ end;
vaSet:
SkipSetBody;
vaCollection:
@@ -749,6 +773,19 @@ begin
raise EReadError.Create(SInvalidPropertyValue);
end;
+function TReader.ReadUnicodeChar: UnicodeChar;
+
+var
+ U: UnicodeString;
+
+begin
+ U := ReadUnicodeString;
+ if Length(U) = 1 then
+ Result := U[1]
+ else
+ raise EReadError.Create(SInvalidPropertyValue);
+end;
+
procedure TReader.ReadCollection(Collection: TCollection);
var
Item: TCollectionItem;
@@ -1172,7 +1209,7 @@ begin
SetOrdProp(Instance, PropInfo, Ord(ReadBoolean));
tkChar:
SetOrdProp(Instance, PropInfo, Ord(ReadChar));
- tkWChar:
+ tkWChar,tkUChar:
SetOrdProp(Instance, PropInfo, Ord(ReadWideChar));
tkEnumeration:
begin
@@ -1211,13 +1248,15 @@ begin
end;
end;
tkSString, tkLString, tkAString:
- begin
- TmpStr:=ReadString;
- if Assigned(FOnReadStringProperty) then
- FOnReadStringProperty(Self,Instance,PropInfo,TmpStr);
- SetStrProp(Instance, PropInfo, TmpStr);
- end;
- tkWstring:
+ begin
+ TmpStr:=ReadString;
+ if Assigned(FOnReadStringProperty) then
+ FOnReadStringProperty(Self,Instance,PropInfo,TmpStr);
+ SetStrProp(Instance, PropInfo, TmpStr);
+ end;
+ tkUstring:
+ SetUnicodeStrProp(Instance,PropInfo,ReadUnicodeString);
+ tkWString:
SetWideStrProp(Instance,PropInfo,ReadWideString);
{!!!: tkVariant}
tkClass:
@@ -1365,6 +1404,8 @@ begin
end
else if StringType in [vaWString] then
Result:= FDriver.ReadWidestring
+ else if StringType in [vaUString] then
+ Result:= FDriver.ReadUnicodeString
else
raise EReadError.Create(SInvalidPropertyValue);
end;
@@ -1375,21 +1416,47 @@ var
s: String;
i: Integer;
begin
- if NextValue in [vaWString,vaUTF8String] then
- begin
- ReadValue;
- Result := FDriver.ReadWideString
- end
- else begin
- //data probable from ObjectTextToBinary
- s := ReadString;
- setlength(result,length(s));
- for i:= 1 to length(s) do begin
- result[i]:= widechar(ord(s[i])); //no code conversion
+ if NextValue in [vaWString,vaUString,vaUTF8String] then
+ //vaUTF8String needs conversion? 2008-09-06 mse
+ begin
+ ReadValue;
+ Result := FDriver.ReadWideString
+ end
+ else
+ begin
+ //data probable from ObjectTextToBinary
+ s := ReadString;
+ setlength(result,length(s));
+ for i:= 1 to length(s) do begin
+ result[i]:= widechar(ord(s[i])); //no code conversion
end;
end;
end;
+
+function TReader.ReadUnicodeString: UnicodeString;
+var
+ s: String;
+ i: Integer;
+begin
+ if NextValue in [vaWString,vaUString,vaUTF8String] then
+ //vaUTF8String needs conversion? 2008-09-06 mse
+ begin
+ ReadValue;
+ Result := FDriver.ReadUnicodeString
+ end
+ else
+ begin
+ //data probable from ObjectTextToBinary
+ s := ReadString;
+ setlength(result,length(s));
+ for i:= 1 to length(s) do begin
+ result[i]:= UnicodeChar(ord(s[i])); //no code conversion
+ end;
+ end;
+end;
+
+
function TReader.ReadValue: TValueType;
begin
Result := FDriver.ReadValue;
diff --git a/rtl/objpas/classes/writer.inc b/rtl/objpas/classes/writer.inc
index a55648cea1..5d09756cf9 100644
--- a/rtl/objpas/classes/writer.inc
+++ b/rtl/objpas/classes/writer.inc
@@ -319,6 +319,29 @@ begin
{$ENDIF}
end;
end;
+
+procedure TBinaryObjectWriter.WriteUnicodeString(const Value: UnicodeString);
+var len : longword;
+{$IFDEF ENDIAN_BIG}
+ i : integer;
+ us : UnicodeString;
+{$ENDIF}
+begin
+ WriteValue(vaUString);
+ len:=Length(Value);
+ WriteDWord(len);
+ if len > 0 then
+ begin
+ {$IFDEF ENDIAN_BIG}
+ setlength(us,len);
+ for i:=1 to len do
+ us[i]:=widechar(SwapEndian(word(Value[i])));
+ Write(us[1], len*sizeof(UnicodeChar));
+ {$ELSE}
+ Write(Value[1], len*sizeof(UnicodeChar));
+ {$ENDIF}
+ end;
+end;
procedure TBinaryObjectWriter.FlushBuffer;
begin
@@ -737,6 +760,7 @@ var
DefMethodValue: TMethod;
WStrValue, WDefStrValue: WideString;
StrValue, DefStrValue: String;
+ UStrValue, UDefStrValue: UnicodeString;
AncestorObj: TObject;
Component: TComponent;
ObjValue: TObject;
@@ -876,6 +900,21 @@ begin
Driver.EndProperty;
end;
end;
+ tkUString:
+ begin
+ UStrValue := GetUnicodeStrProp(Instance, PropInfo);
+ if HasAncestor then
+ UDefStrValue := GetUnicodeStrProp(Ancestor, PropInfo)
+ else
+ SetLength(UDefStrValue, 0);
+
+ if UStrValue <> UDefStrValue then
+ begin
+ Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
+ WriteUnicodeString(UStrValue);
+ Driver.EndProperty;
+ end;
+ end;
{!!!: tkVariant:}
tkClass:
begin
@@ -1013,3 +1052,8 @@ begin
Driver.WriteWideString(Value);
end;
+procedure TWriter.WriteUnicodeString(const Value: UnicodeString);
+begin
+ Driver.WriteUnicodeString(Value);
+end;
+
diff --git a/rtl/objpas/sysutils/sysformt.inc b/rtl/objpas/sysutils/sysformt.inc
index fd75384312..e45f4f4779 100644
--- a/rtl/objpas/sysutils/sysformt.inc
+++ b/rtl/objpas/sysutils/sysformt.inc
@@ -143,7 +143,11 @@ Var ChPos,OldPos,ArgPos,DoArg,Len : SizeInt;
ReadWidth;
ReadPrec;
{$ifdef INWIDEFORMAT}
+{$ifdef VER2_2}
FormatChar:=UpCase(Fmt[ChPos])[1];
+{$else VER2_2}
+ FormatChar:=UpCase(UnicodeChar(Fmt[ChPos]));
+{$endif VER2_2}
if word(FormatChar)>255 then
ReadFormat:=#255
else
diff --git a/rtl/objpas/typinfo.pp b/rtl/objpas/typinfo.pp
index 30688766df..85d823b7ce 100644
--- a/rtl/objpas/typinfo.pp
+++ b/rtl/objpas/typinfo.pp
@@ -38,7 +38,7 @@ unit typinfo;
tkSet,tkMethod,tkSString,tkLString,tkAString,
tkWString,tkVariant,tkArray,tkRecord,tkInterface,
tkClass,tkObject,tkWChar,tkBool,tkInt64,tkQWord,
- tkDynArray,tkInterfaceRaw);
+ tkDynArray,tkInterfaceRaw,tkProcVar,tkUString,tkUChar);
TOrdType = (otSByte,otUByte,otSWord,otUWord,otSLong,otULong);
@@ -85,7 +85,7 @@ unit typinfo;
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
case TTypeKind of
- tkUnKnown,tkLString,tkWString,tkAString,tkVariant:
+ tkUnKnown,tkLString,tkWString,tkAString,tkVariant,tkUString:
();
tkInteger,tkChar,tkEnumeration,tkWChar,tkSet:
(OrdType : TOrdType;
@@ -252,6 +252,11 @@ Function GetWideStrProp(Instance: TObject; const PropName: string): WideString;
Procedure SetWideStrProp(Instance: TObject; const PropName: string; const Value: WideString);
Procedure SetWideStrProp(Instance: TObject; PropInfo: PPropInfo; const Value: WideString);
+Function GetUnicodeStrProp(Instance: TObject; PropInfo: PPropInfo): UnicodeString;
+Function GetUnicodeStrProp(Instance: TObject; const PropName: string): UnicodeString;
+Procedure SetUnicodeStrProp(Instance: TObject; const PropName: string; const Value: UnicodeString);
+Procedure SetUnicodeStrProp(Instance: TObject; PropInfo: PPropInfo; const Value: UnicodeString);
+
{$ifndef FPUNONE}
Function GetFloatProp(Instance: TObject; PropInfo : PPropInfo) : Extended;
Function GetFloatProp(Instance: TObject; const PropName: string): Extended;
@@ -1397,6 +1402,91 @@ begin
end;
end;
+Function GetUnicodeStrProp(Instance: TObject; const PropName: string): UnicodeString;
+begin
+ Result:=GetUnicodeStrProp(Instance, FindPropInfo(Instance, PropName));
+end;
+
+
+procedure SetUnicodeStrProp(Instance: TObject; const PropName: string; const Value: UnicodeString);
+begin
+ SetUnicodeStrProp(Instance,FindPropInfo(Instance,PropName),Value);
+end;
+
+
+Function GetUnicodeStrProp(Instance: TObject; PropInfo: PPropInfo): UnicodeString;
+type
+ TGetUnicodeStrProcIndex=function(index:longint):UnicodeString of object;
+ TGetUnicodeStrProc=function():UnicodeString of object;
+var
+ AMethod : TMethod;
+begin
+ Result:='';
+ case Propinfo^.PropType^.Kind of
+ tkSString,tkAString:
+ Result:=GetStrProp(Instance,PropInfo);
+ tkWString:
+ Result:=GetWideStrProp(Instance,PropInfo);
+ tkUString:
+ begin
+ case (PropInfo^.PropProcs) and 3 of
+ ptField:
+ Result := PUnicodeString(Pointer(Instance)+PtrUInt(PropInfo^.GetProc))^;
+ ptstatic,
+ ptvirtual :
+ begin
+ if (PropInfo^.PropProcs and 3)=ptStatic then
+ AMethod.Code:=PropInfo^.GetProc
+ else
+ AMethod.Code:=PPointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.GetProc))^;
+ AMethod.Data:=Instance;
+ if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
+ Result:=TGetUnicodeStrProcIndex(AMethod)(PropInfo^.Index)
+ else
+ Result:=TGetUnicodeStrProc(AMethod)();
+ end;
+ end;
+ end;
+ end;
+end;
+
+
+Procedure SetUnicodeStrProp(Instance: TObject; PropInfo: PPropInfo; const Value: UnicodeString);
+type
+ TSetUnicodeStrProcIndex=procedure(index:longint;s:UnicodeString) of object;
+ TSetUnicodeStrProc=procedure(s:UnicodeString) of object;
+var
+ AMethod : TMethod;
+begin
+ case Propinfo^.PropType^.Kind of
+ tkSString,tkAString:
+ SetStrProp(Instance,PropInfo,Value);
+ tkWString:
+ SetWideStrProp(Instance,PropInfo,Value);
+ tkUString:
+ begin
+ case (PropInfo^.PropProcs shr 2) and 3 of
+ ptField:
+ PUnicodeString(Pointer(Instance)+PtrUInt(PropInfo^.SetProc))^:=Value;
+ ptstatic,
+ ptvirtual :
+ begin
+ if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then
+ AMethod.Code:=PropInfo^.SetProc
+ else
+ AMethod.Code:=PPointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.SetProc))^;
+ AMethod.Data:=Instance;
+ if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
+ TSetUnicodeStrProcIndex(AMethod)(PropInfo^.Index,Value)
+ else
+ TSetUnicodeStrProc(AMethod)(Value);
+ end;
+ end;
+ end;
+ end;
+end;
+
+
{$ifndef FPUNONE}
diff --git a/rtl/unix/cwstring.pp b/rtl/unix/cwstring.pp
index e4108af2d1..860613b9f8 100644
--- a/rtl/unix/cwstring.pp
+++ b/rtl/unix/cwstring.pp
@@ -705,7 +705,7 @@ end;
Procedure SetCWideStringManager;
Var
- CWideStringManager : TWideStringManager;
+ CWideStringManager : TUnicodeStringManager;
begin
CWideStringManager:=widestringmanager;
With CWideStringManager do
@@ -733,8 +733,15 @@ begin
StrUpperAnsiStringProc:=@AnsiStrUpper;
ThreadInitProc:=@InitThread;
ThreadFiniProc:=@FiniThread;
+{$ifndef VER2_2}
+ { Unicode }
+ Unicode2AnsiMoveProc:=@Wide2AnsiMove;
+ Ansi2UnicodeMoveProc:=@Ansi2WideMove;
+ UpperUnicodeStringProc:=@UpperWideString;
+ LowerUnicodeStringProc:=@LowerWideString;
+{$endif VER2_2}
end;
- SetWideStringManager(CWideStringManager);
+ SetUnicodeStringManager(CWideStringManager);
end;
@@ -752,3 +759,4 @@ finalization
{ fini conversion tables for main program }
FiniThread;
end.
+
diff --git a/rtl/win32/buildrtl.lpi b/rtl/win32/buildrtl.lpi
index 8c72981d5a..55c3f36caa 100644
--- a/rtl/win32/buildrtl.lpi
+++ b/rtl/win32/buildrtl.lpi
@@ -12,6 +12,7 @@
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
+ <IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
<Title Value="buildrtl"/>
</General>
diff --git a/rtl/win32/system.pp b/rtl/win32/system.pp
index 9d0a1197ec..e1fad07a70 100644
--- a/rtl/win32/system.pp
+++ b/rtl/win32/system.pp
@@ -899,10 +899,6 @@ end;
{$endif Set_i386_Exception_handler}
-{****************************************************************************
- OS dependend widestrings
-****************************************************************************}
-
const
{ MultiByteToWideChar }
MB_PRECOMPOSED = 1;
@@ -918,6 +914,9 @@ function CharUpperBuff(lpsz:LPWSTR; cchLength:DWORD):DWORD;
function CharLowerBuff(lpsz:LPWSTR; cchLength:DWORD):DWORD;
stdcall; external 'user32' name 'CharLowerBuffW';
+{******************************************************************************
+ Widestring
+ ******************************************************************************}
procedure Win32Wide2AnsiMove(source:pwidechar;var dest:ansistring;len:SizeInt);
var
@@ -947,13 +946,57 @@ procedure Win32Ansi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
function Win32WideUpper(const s : WideString) : WideString;
begin
result:=s;
- UniqueString(result);
if length(result)>0 then
CharUpperBuff(LPWSTR(result),length(result));
end;
function Win32WideLower(const s : WideString) : WideString;
+ begin
+ result:=s;
+ if length(result)>0 then
+ CharLowerBuff(LPWSTR(result),length(result));
+ end;
+
+{******************************************************************************
+ Unicode
+ ******************************************************************************}
+
+procedure Win32Unicode2AnsiMove(source:punicodechar;var dest:ansistring;len:SizeInt);
+ var
+ destlen: SizeInt;
+ begin
+ // retrieve length including trailing #0
+ // not anymore, because this must also be usable for single characters
+ destlen:=WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, source, len, nil, 0, nil, nil);
+ // this will null-terminate
+ setlength(dest, destlen);
+ WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, source, len, @dest[1], destlen, nil, nil);
+ end;
+
+procedure Win32Ansi2UnicodeMove(source:pchar;var dest:UnicodeString;len:SizeInt);
+ var
+ destlen: SizeInt;
+ begin
+ // retrieve length including trailing #0
+ // not anymore, because this must also be usable for single characters
+ destlen:=MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len, nil, 0);
+ // this will null-terminate
+ setlength(dest, destlen);
+ MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len, @dest[1], destlen);
+ end;
+
+
+function Win32UnicodeUpper(const s : UnicodeString) : UnicodeString;
+ begin
+ result:=s;
+ UniqueString(result);
+ if length(result)>0 then
+ CharUpperBuff(LPWSTR(result),length(result));
+ end;
+
+
+function Win32UnicodeLower(const s : UnicodeString) : UnicodeString;
begin
result:=s;
UniqueString(result);
@@ -966,10 +1009,18 @@ function Win32WideLower(const s : WideString) : WideString;
are only relevant for the sysutils units }
procedure InitWin32Widestrings;
begin
+ { Widestring }
widestringmanager.Wide2AnsiMoveProc:=@Win32Wide2AnsiMove;
widestringmanager.Ansi2WideMoveProc:=@Win32Ansi2WideMove;
widestringmanager.UpperWideStringProc:=@Win32WideUpper;
widestringmanager.LowerWideStringProc:=@Win32WideLower;
+{$ifndef VER2_2}
+ { Unicode }
+ widestringmanager.Unicode2AnsiMoveProc:=@Win32Unicode2AnsiMove;
+ widestringmanager.Ansi2UnicodeMoveProc:=@Win32Ansi2UnicodeMove;
+ widestringmanager.UpperUnicodeStringProc:=@Win32UnicodeUpper;
+ widestringmanager.LowerUnicodeStringProc:=@Win32UnicodeLower;
+{$endif VER2_2}
end;
@@ -1192,6 +1243,10 @@ begin
errno:=0;
initvariantmanager;
initwidestringmanager;
+{$ifndef VER2_2}
+ initunicodestringmanager;
+{$endif VER2_2}
InitWin32Widestrings;
DispCallByIDProc:=@DoDispCallByIDError;
end.
+
diff --git a/tests/test/trtti1.pp b/tests/test/trtti1.pp
index d484bcaf32..ce454e6e6e 100644
--- a/tests/test/trtti1.pp
+++ b/tests/test/trtti1.pp
@@ -11,7 +11,7 @@ Const TypeNames : Array [TTYpeKind] of string[15] =
'Float','Set','Method','ShortString','LongString',
'AnsiString','WideString','Variant','Array','Record',
'Interface','Class','Object','WideChar','Bool','Int64','QWord',
- 'DynamicArray','RawInterface');
+ 'DynamicArray','RawInterface','ProcVar','UnicodeString','UnicodeChar');
Const OrdinalTypes = [tkInteger,tkChar,tkENumeration,tkbool];
diff --git a/tests/test/tstring10.pp b/tests/test/tstring10.pp
new file mode 100644
index 0000000000..905a7dda53
--- /dev/null
+++ b/tests/test/tstring10.pp
@@ -0,0 +1,27 @@
+program punicodechartest;
+{$ifdef FPC}{$mode objfpc}{$h+}{$endif}
+{$ifdef mswindows}{$apptype console}{$endif}
+uses
+ {$ifdef FPC}{$ifdef linux}cthreads,{$endif}{$endif}
+ sysutils;
+var
+ astr: ansistring;
+ wstr: widestring;
+ ustr: unicodestring;
+begin
+ astr:= '';
+ wstr:= '';
+ ustr:= '';
+ writeln(ptrint(pansichar(astr)));
+ flush(output);
+ writeln(ptrint(pwidechar(wstr)));
+ flush(output);
+ writeln(ptrint(punicodechar(ustr)));
+ flush(output);
+ writeln(ord(pansichar(astr)^));
+ flush(output);
+ writeln(ord(pwidechar(wstr)^));
+ flush(output);
+ writeln(ord(punicodechar(ustr)^));
+ flush(output);
+end.
diff --git a/tests/test/tunistr1.pp b/tests/test/tunistr1.pp
new file mode 100644
index 0000000000..c4cb0d7da1
--- /dev/null
+++ b/tests/test/tunistr1.pp
@@ -0,0 +1,19 @@
+{$ifdef unix}
+uses
+ cwstring;
+{$endif unix}
+
+var
+ w : unicodestring;
+ a : ansistring;
+
+begin
+ a:='A';
+ w:=a;
+ if w[1]<>#65 then
+ halt(1);
+ a:=w;
+ if a[1]<>'A' then
+ halt(1);
+ writeln('ok');
+end.
diff --git a/tests/test/tunistr2.pp b/tests/test/tunistr2.pp
new file mode 100644
index 0000000000..8e9c1824c3
--- /dev/null
+++ b/tests/test/tunistr2.pp
@@ -0,0 +1,21 @@
+{$ifdef UNIX}
+uses
+ cwstring;
+{$endif UNIX}
+
+var
+ i : longint;
+ w,w2 : unicodestring;
+ a : ansistring;
+
+begin
+ setlength(w,1000);
+ for i:=1 to 1000 do
+ w[i]:=widechar(i);
+ for i:=1 to 10 do
+ begin
+ a:=w;
+ w2:=a;
+ end;
+ writeln('ok');
+end.
diff --git a/tests/test/tunistr4.pp b/tests/test/tunistr4.pp
new file mode 100644
index 0000000000..0ca80e047f
--- /dev/null
+++ b/tests/test/tunistr4.pp
@@ -0,0 +1,92 @@
+
+{$ifdef fpc}
+{$mode objfpc}
+{$endif fpc}
+
+uses
+{$ifdef unix}
+ cthreads, cwstring,
+{$endif}
+ Classes, SysUtils;
+
+type
+ tc = class(tthread)
+ orgstr: ansistring;
+ cnvstr: unicodestring;
+ constructor create(const s: ansistring; const w: unicodestring);
+ procedure execute; override;
+ end;
+
+const
+ // string with an invalid utf-8 code sequence
+ str1 = #$c1#$34'Życie'#$c1#$34' jest jak papier '#$c1#$34'toaletowy'#$c1#$34' : długie, szare i '#$c1#$34'do'#$c1#$34' dupy';
+ str2 = 'Życie '#$c1#$34'jest'#$c1#$34' jak papier toaletowy : '#$c1#$34'długie'#$c1#$34', szare i do '#$c1#$34'dupy'#$c1#$34'222222222222222222222222222222222222222222222222';
+ str3 = 'Życie jest '#$c1#$34'jak'#$c1#$34' papier 333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333 toaletowy : długie, '#$c1#$34'szare'#$c1#$34' i do dupy';
+ str4 = 'Życie jest 4444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444 jak '#$c1#$34'papier'#$c1#$34' toaletowy : długie, szare '#$c1#$34'i'#$c1#$34' do dupy';
+ count = 20000;
+
+var
+ wstr: unicodestring;
+// cnvstr: ansistring;
+ error: boolean;
+
+
+constructor tc.create(const s: ansistring; const w: unicodestring);
+begin
+ orgstr:=s;
+ cnvstr:=w;
+ inherited create(true);
+end;
+
+
+procedure tc.execute;
+var
+ i: longint;
+ w: unicodestring;
+begin
+ for i := 1 to count do
+ begin
+ w:=orgstr;
+ if (w<>cnvstr) then
+ error:=true;
+ end;
+end;
+
+var
+ a: array[1..4] of tc;
+ w1,w2,w3,w4: unicodestring;
+ cnvstr: ansistring;
+begin
+ error:=false;
+ cnvstr:=str1;
+ w1:=cnvstr;
+ cnvstr:=str2;
+ w2:=cnvstr;
+ cnvstr:=str3;
+ w3:=cnvstr;
+ cnvstr:=str4;
+ w4:=cnvstr;
+ writeln(w1);
+ writeln(w2);
+ writeln(w3);
+ writeln(w4);
+ a[1]:=tc.create(str1,w1);
+ a[2]:=tc.create(str2,w2);
+ a[3]:=tc.create(str3,w3);
+ a[4]:=tc.create(str4,w4);
+ a[1].resume;
+ a[2].resume;
+ a[3].resume;
+ a[4].resume;
+ a[1].waitfor;
+ a[2].waitfor;
+ a[3].waitfor;
+ a[4].waitfor;
+ a[1].free;
+ a[2].free;
+ a[3].free;
+ a[4].free;
+
+ if error then
+ halt(1);
+end.
diff --git a/tests/test/tunistr5.pp b/tests/test/tunistr5.pp
new file mode 100644
index 0000000000..b09a333a54
--- /dev/null
+++ b/tests/test/tunistr5.pp
@@ -0,0 +1,45 @@
+{$codepage utf-8}
+
+var
+ ws: unicodestring;
+ us: UCS4String;
+begin
+// the compiler does not yet support characters which require
+// a surrogate pair in utf-16
+// ws:='鳣ćçŹ你';
+// so write the last character directly using a utf-16 surrogate pair
+ ws:='鳣ćçŹ'#$d87e#$dc04;
+
+ if (length(ws)<>8) or
+ (ws[1]<>'é') or
+ (ws[2]<>'ł') or
+ (ws[3]<>'Ł') or
+ (ws[4]<>'ć') or
+ (ws[5]<>'ç') or
+ (ws[6]<>'Ź') or
+ (ws[7]<>#$d87e) or
+ (ws[8]<>#$dc04) then
+ halt(1);
+ us:=UnicodeStringToUCS4String(ws);
+ if (length(us)<>8) or
+ (us[0]<>UCS4Char(unicodechar('é'))) or
+ (us[1]<>UCS4Char(unicodechar('ł'))) or
+ (us[2]<>UCS4Char(unicodechar('Ł'))) or
+ (us[3]<>UCS4Char(unicodechar('ć'))) or
+ (us[4]<>UCS4Char(unicodechar('ç'))) or
+ (us[5]<>UCS4Char(unicodechar('Ź'))) or
+ (us[6]<>UCS4Char($2F804)) or
+ (us[7]<>UCS4Char(0)) then
+ halt(2);
+ ws:=UCS4StringToUnicodeString(us);
+ if (length(ws)<>8) or
+ (ws[1]<>'é') or
+ (ws[2]<>'ł') or
+ (ws[3]<>'Ł') or
+ (ws[4]<>'ć') or
+ (ws[5]<>'ç') or
+ (ws[6]<>'Ź') or
+ (ws[7]<>#$d87e) or
+ (ws[8]<>#$dc04) then
+ halt(3);
+end.
diff --git a/tests/test/tunistr6.pp b/tests/test/tunistr6.pp
new file mode 100644
index 0000000000..033892d172
--- /dev/null
+++ b/tests/test/tunistr6.pp
@@ -0,0 +1,397 @@
+{%skiptarget=wince}
+{$codepage utf-8}
+uses
+ {$ifdef unix}
+ cwstring,
+ {$endif}
+ sysutils;
+
+procedure doerror(i : integer);
+ begin
+ writeln('Error: ',i);
+ halt(i);
+ end;
+
+
+{ normal upper case testing }
+procedure testupper;
+var
+ s: ansistring;
+ w1,w2,w3,w4: unicodestring;
+ i: longint;
+begin
+ w1:='aé'#0'èàł'#$d87e#$dc04;
+ w2:='AÉ'#0'ÈÀŁ'#$d87e#$dc04;
+{$ifdef print}
+// the utf-8 output can confuse the testsuite parser
+ writeln('original: ',w1);
+ writeln('original upper: ',w2);
+{$endif print}
+ s:=w1;
+{$ifdef print}
+ writeln('ansi: ',s);
+{$endif print}
+ w3:=s;
+ w4:=AnsiUpperCase(s);
+ { filter out unsupported characters }
+ for i:=1 to length(w3) do
+ if w3[i]='?' then
+ begin
+ w2[i]:='?';
+ w1[i]:='?';
+ end;
+ w1:=UnicodeUpperCase(w1);
+{$ifdef print}
+ writeln('unicodeupper: ',w1);
+ writeln('original upper: ',w2);
+ writeln('ansiupper: ',w4);
+{$endif print}
+ if (w1 <> w2) then
+ doerror(1);
+ if (w4 <> w2) then
+ doerror(2);
+
+ w1:='aéèàł'#$d87e#$dc04;
+ w2:='AÉÈÀŁ'#$d87e#$dc04;
+ s:=w1;
+ w3:=s;
+ w4:=AnsiStrUpper(pchar(s));
+ { filter out unsupported characters }
+ for i:=1 to length(w3) do
+ if w3[i]='?' then
+ begin
+ w2[i]:='?';
+ w1[i]:='?';
+ end;
+ w1:=UnicodeUpperCase(w1);
+{$ifdef print}
+ writeln('unicodeupper: ',w1);
+ writeln('ansistrupper: ',w4);
+{$endif print}
+ if (w1 <> w2) then
+ doerror(21);
+ if (w4 <> w2) then
+ doerror(22);
+
+end;
+
+
+{ normal lower case testing }
+procedure testlower;
+var
+ s: ansistring;
+ w1,w2,w3,w4: unicodestring;
+ i: longint;
+begin
+ w1:='AÉ'#0'ÈÀŁ'#$d87e#$dc04;
+ w2:='aé'#0'èàł'#$d87e#$dc04;
+{$ifdef print}
+// the utf-8 output can confuse the testsuite parser
+ writeln('original: ',w1);
+ writeln('original lower: ',w2);
+{$endif print}
+ s:=w1;
+ w3:=s;
+ w4:=AnsiLowerCase(s);
+ { filter out unsupported characters }
+ for i:=1 to length(w3) do
+ if w3[i]='?' then
+ begin
+ w2[i]:='?';
+ w1[i]:='?';
+ end;
+ w1:=UnicodeLowerCase(w1);
+{$ifdef print}
+ writeln('unicodelower: ',w1);
+ writeln('ansilower: ',w4);
+{$endif print}
+ if (w1 <> w2) then
+ doerror(3);
+ if (w4 <> w2) then
+ doerror(4);
+
+
+ w1:='AÉÈÀŁ'#$d87e#$dc04;
+ w2:='aéèàł'#$d87e#$dc04;
+ s:=w1;
+ w3:=s;
+ w4:=AnsiStrLower(pchar(s));
+ { filter out unsupported characters }
+ for i:=1 to length(w3) do
+ if w3[i]='?' then
+ begin
+ w2[i]:='?';
+ w1[i]:='?';
+ end;
+ w1:=UnicodeLowerCase(w1);
+{$ifdef print}
+ writeln('unicodelower: ',w1);
+ writeln('ansistrlower: ',w4);
+{$endif print}
+ if (w1 <> w2) then
+ doerror(3);
+ if (w4 <> w2) then
+ doerror(4);
+end;
+
+
+
+{ upper case testing with a missing utf-16 pair at the end }
+procedure testupperinvalid;
+var
+ s: ansistring;
+ w1,w2,w3,w4: unicodestring;
+ i: longint;
+begin
+ { missing utf-16 pair at end }
+ w1:='aé'#0'èàł'#$d87e;
+ w2:='AÉ'#0'ÈÀŁ'#$d87e;
+{$ifdef print}
+// the utf-8 output can confuse the testsuite parser
+ writeln('original: ',w1);
+ writeln('original upper: ',w2);
+{$endif print}
+ s:=w1;
+ w3:=s;
+ w4:=AnsiUpperCase(s);
+ { filter out unsupported characters }
+ for i:=1 to length(w3) do
+ if w3[i]='?' then
+ begin
+ w2[i]:='?';
+ w1[i]:='?';
+ end;
+ w1:=UnicodeUpperCase(w1);
+{$ifdef print}
+ writeln('unicodeupper: ',w1);
+ writeln('ansiupper: ',w4);
+{$endif print}
+ if (w1 <> w2) then
+ doerror(5);
+ if (w4 <> w2) then
+ doerror(6);
+end;
+
+
+{ lower case testing with a missing utf-16 pair at the end }
+procedure testlowerinvalid;
+var
+ s: ansistring;
+ w1,w2,w3,w4: unicodestring;
+ i: longint;
+begin
+ { missing utf-16 pair at end}
+ w1:='AÉ'#0'ÈÀŁ'#$d87e;
+ w2:='aé'#0'èàł'#$d87e;
+{$ifdef print}
+// the utf-8 output can confuse the testsuite parser
+ writeln('original: ',w1);
+ writeln('original lower: ',w2);
+{$endif print}
+ s:=w1;
+ w3:=s;
+ w4:=AnsiLowerCase(s);
+ { filter out unsupported characters }
+ for i:=1 to length(w3) do
+ if w3[i]='?' then
+ begin
+ w2[i]:='?';
+ w1[i]:='?';
+ end;
+ w1:=UnicodeLowerCase(w1);
+{$ifdef print}
+ writeln('unicodelower: ',w1);
+ writeln('ansilower: ',w4);
+{$endif print}
+ if (w1 <> w2) then
+ doerror(7);
+ if (w4 <> w2) then
+ doerror(8);
+end;
+
+
+
+{ upper case testing with a missing utf-16 pair at the end, followed by a normal char }
+procedure testupperinvalid1;
+var
+ s: ansistring;
+ w1,w2,w3,w4: unicodestring;
+ i: longint;
+begin
+ { missing utf-16 pair at end with char after it}
+ w1:='aé'#0'èàł'#$d87e'j';
+ w2:='AÉ'#0'ÈÀŁ'#$d87e'J';
+{$ifdef print}
+// the utf-8 output can confuse the testsuite parser
+ writeln('original: ',w1);
+ writeln('original upper: ',w2);
+{$endif print}
+ s:=w1;
+ w3:=s;
+ w4:=AnsiUpperCase(s);
+ { filter out unsupported characters }
+ for i:=1 to length(w3) do
+ if w3[i]='?' then
+ begin
+ w2[i]:='?';
+ w1[i]:='?';
+ end;
+ w1:=UnicodeUpperCase(w1);
+{$ifdef print}
+ writeln('unicodeupper: ',w1);
+ writeln('ansiupper: ',w4);
+{$endif print}
+ if (w1 <> w2) then
+ doerror(9);
+ if (w4 <> w2) then
+ doerror(10);
+end;
+
+
+{ lower case testing with a missing utf-16 pair at the end, followed by a normal char }
+procedure testlowerinvalid1;
+var
+ s: ansistring;
+ w1,w2,w3,w4: unicodestring;
+ i: longint;
+begin
+ { missing utf-16 pair at end with char after it}
+ w1:='AÉ'#0'ÈÀŁ'#$d87e'J';
+ w2:='aé'#0'èàł'#$d87e'j';
+{$ifdef print}
+// the utf-8 output can confuse the testsuite parser
+ writeln('original: ',w1);
+ writeln('original lower: ',w2);
+{$endif print}
+ s:=w1;
+ w3:=s;
+ w4:=AnsiLowerCase(s);
+ { filter out unsupported characters }
+ for i:=1 to length(w3) do
+ if w3[i]='?' then
+ begin
+ w2[i]:='?';
+ w1[i]:='?';
+ end;
+ w1:=UnicodeLowerCase(w1);
+{$ifdef print}
+ writeln('unicodelower: ',w1);
+ writeln('ansilower: ',w4);
+{$endif print}
+ if (w1 <> w2) then
+ doerror(11);
+ if (w4 <> w2) then
+ doerror(12);
+end;
+
+
+{ upper case testing with corrupting the utf-8 string after conversion }
+procedure testupperinvalid2;
+var
+ s: ansistring;
+ w1,w2,w3,w4: unicodestring;
+ i: longint;
+begin
+ w1:='aé'#0'èàł'#$d87e#$dc04'ö';
+ w2:='AÉ'#0'ÈÀŁ'#$d87e#$dc04'Ö';
+{$ifdef print}
+// the utf-8 output can confuse the testsuite parser
+ writeln('original: ',w1);
+ writeln('original upper: ',w2);
+{$endif print}
+ s:=w1;
+ { truncate the last utf-8 character }
+ setlength(s,length(s)-1);
+ w3:=s;
+ { adjust checking values for new length due to corruption }
+ if length(w3)<>length(w2) then
+ begin
+ setlength(w2,length(w3));
+ setlength(w1,length(w3));
+ end;
+ w4:=AnsiUpperCase(s);
+ { filter out unsupported characters }
+ for i:=1 to length(w3) do
+ if w3[i]='?' then
+ begin
+ w2[i]:='?';
+ w1[i]:='?';
+ end;
+ w1:=UnicodeUpperCase(w1);
+{$ifdef print}
+ writeln('unicodeupper: ',w1);
+ writeln('ansiupper: ',w4);
+{$endif print}
+ if (w1 <> w2) then
+ doerror(13);
+ if (w4 <> w2) then
+ doerror(14);
+end;
+
+
+{ lower case testing with corrupting the utf-8 string after conversion }
+procedure testlowerinvalid2;
+var
+ s: ansistring;
+ w1,w2,w3,w4: unicodestring;
+ i: longint;
+begin
+ w1:='AÉ'#0'ÈÀŁ'#$d87e#$dc04'Ö';
+ w2:='aé'#0'èàł'#$d87e#$dc04'ö';
+{$ifdef print}
+// the utf-8 output can confuse the testsuite parser
+ writeln('original: ',w1);
+ writeln('original lower: ',w2);
+{$endif print}
+ s:=w1;
+ { truncate the last utf-8 character }
+ setlength(s,length(s)-1);
+ w3:=s;
+ { adjust checking values for new length due to corruption }
+ if length(w3)<>length(w2) then
+ begin
+ setlength(w2,length(w3));
+ setlength(w1,length(w3));
+ end;
+ w4:=AnsiLowerCase(s);
+ { filter out unsupported characters }
+ for i:=1 to length(w3) do
+ if w3[i]='?' then
+ begin
+ w2[i]:='?';
+ w1[i]:='?';
+ end;
+ w1:=UnicodeLowerCase(w1);
+{$ifdef print}
+ writeln('unicodelower: ',w1);
+ writeln('ansilower: ',w4);
+{$endif print}
+ if (w1 <> w2) then
+ doerror(15);
+ if (w4 <> w2) then
+ doerror(16);
+end;
+
+
+
+begin
+ testupper;
+ writeln;
+ testlower;
+ writeln;
+ writeln;
+ testupperinvalid;
+ writeln;
+ testlowerinvalid;
+ writeln;
+ writeln;
+ testupperinvalid1;
+ writeln;
+ testlowerinvalid1;
+ writeln;
+ writeln;
+ testupperinvalid2;
+ writeln;
+ testlowerinvalid2;
+ writeln('ok');
+end.
diff --git a/tests/test/tunistr7.pp b/tests/test/tunistr7.pp
new file mode 100644
index 0000000000..c7623793d8
--- /dev/null
+++ b/tests/test/tunistr7.pp
@@ -0,0 +1,47 @@
+{$codepage utf-8}
+
+uses
+{$ifdef unix}
+ cwstring,
+{$endif unix}
+ sysutils;
+
+procedure testwcmp;
+var
+ w1,w2: unicodestring;
+ s: ansistring;
+begin
+ w1:='aécde';
+ { filter unsupported characters }
+ s:=w1;
+ w1:=s;
+ w2:=w1;
+
+ if (w1<>w2) then
+ halt(1);
+ w1[2]:='f';
+ if (w1=w2) or
+ WideSameStr(w1,w2) or
+ (WideCompareText(w1,w2)=0) or
+ (WideCompareStr(w1,w2)<0) or
+ (WideCompareStr(w2,w1)>0) then
+ halt(2);
+ w1[2]:=#0;
+ w2[2]:=#0;
+ if (w1<>w2) or
+ not WideSameStr(w1,w2) or
+ (WideCompareStr(w1,w2)<>0) or
+ (WideCompareText(w1,w2)<>0) then
+ halt(3);
+ w1[3]:='m';
+ if WideSameStr(w1,w2) or
+ (WideCompareText(w1,w2)=0) or
+ (WideCompareStr(w1,w2)<0) or
+ (WideCompareStr(w2,w1)>0) then
+ halt(4);
+end;
+
+
+begin
+ testwcmp;
+end.