paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-03 08:09:53 +01:00
Code Issues Packages Projects Releases Wiki Activity

* fixed initialising an array of ansichar typed constant using a string

Browse Source 
constant: directly encode the character values in the constant, rather
    than letting unicodestr_to_chararray handle the conversion (which
    implies a codepage conversion)

git-svn-id: trunk@33158 -
This commit is contained in:
Jonas Maebe 2016-03-05 15:32:18 +00:00
parent 599426f2f0
commit 531ce3be61
3 changed files with 111 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

144
compiler/jvm/njvmtcon.pas
View File

@ -42,6 +42,7 @@ interface
tjvmtypedconstbuilder = class(tnodetreetypedconstbuilder)
private
procedure tc_flush_arr_strconst(def: tdef);
procedure tc_emit_arr_strconst_ele(val: int64; def: torddef);
protected
arrstringdata: tarrstringdata;
parsingordarray: boolean;
@ -55,8 +56,9 @@ implementation
uses
globals,widestr,verbose,constexp,
tokens,scanner,pexpr,
defutil,
nbas,ncal,ncon,njvmcon;
nbas,ncal,ncon,ncnv,njvmcon;
procedure init_arrstringdata(out data: tarrstringdata);
@ -88,7 +90,9 @@ implementation
tcompilerwidechar(ord(arrstringdata.arrstring[length(arrstringdata.arrstring)]) shl 8));
if is_signed(def) then
if is_char(def) then
procvariant:='ansichar'
else if is_signed(def) then
case def.size of
1: procvariant:='shortint';
2: procvariant:='smallint';
@ -121,14 +125,54 @@ implementation
end;
procedure tjvmtypedconstbuilder.tc_emit_arr_strconst_ele(val: int64; def: torddef);
var
elesize: longint;
begin
elesize:=def.size;
inc(arrstringdata.arrdatalen);
case elesize of
1:
arrstringdata.arrstring:=arrstringdata.arrstring+char(val);
2:
arrstringdata.arrstring:=arrstringdata.arrstring+char(val shr 8)+char(val and $ff);
4:
arrstringdata.arrstring:=arrstringdata.arrstring+char((val shr 24))+
char((val shr 16) and $ff)+
char((val shr 8) and $ff)+
char(val and $ff);
8:
arrstringdata.arrstring:=arrstringdata.arrstring+char((val shr 56))+
char((val shr 48) and $ff)+
char((val shr 40) and $ff)+
char((val shr 32) and $ff)+
char((val shr 24) and $ff)+
char((val shr 16) and $ff)+
char((val shr 8) and $ff)+
char(val and $ff);
end;
{ we can't use the full 64kb, because inside the Java class file the
string constant is actually encoded using UTF-8 and it's this UTF-8
encoding that has to fit inside 64kb (and utf-8 encoding of random
data can easily blow up its size by about a third) }
if length(arrstringdata.arrstring)>40000 then
tc_flush_arr_strconst(def);
end;
procedure tjvmtypedconstbuilder.parse_arraydef(def: tarraydef);
var
n: tnode;
i, len: longint;
ca: pbyte;
ch: array[0..1] of char;
old_arrstringdata: tarrstringdata;
old_parsingordarray: boolean;
begin
if is_dynamic_array(def) or
not is_integer(def.elementdef) or
not(ts_compact_int_array_init in current_settings.targetswitches) then
(not is_char(def.elementdef) and
(not is_integer(def.elementdef) or
not(ts_compact_int_array_init in current_settings.targetswitches))) then
begin
inherited;
exit;
@ -138,7 +182,66 @@ implementation
arrstringdata.arraybase:=basenode.getcopy;
old_parsingordarray:=parsingordarray;
parsingordarray:=true;
inherited;
if (token=_LKLAMMER) or
not is_char(def.elementdef) then
inherited
else
begin
{ array of ansichar -> can be constant char/string; can't use plain
assignment in this case, because it will result in a codepage
conversion }
n:=comp_expr([ef_accept_equal]);
if n.nodetype=stringconstn then
begin
len:=tstringconstnode(n).len;
if (tstringconstnode(n).cst_type in [cst_unicodestring,cst_widestring]) then
inserttypeconv(n,getansistringdef);
if n.nodetype<>stringconstn then
internalerror(2010033003);
ca:=pbyte(tstringconstnode(n).value_str);
{ For tp7 the maximum lentgh can be 255 }
if (m_tp7 in current_settings.modeswitches) and
(len>255) then
len:=255;
end
else if is_constcharnode(n) then
begin
ch[0]:=chr(tordconstnode(n).value.uvalue and $ff);
ca:=@ch;
len:=1;
end
else if is_constwidecharnode(n) and (current_settings.sourcecodepage<>CP_UTF8) then
begin
inserttypeconv(n,cansichartype);
if not is_constcharnode(n) then
internalerror(2010033001);
ch[0]:=chr(tordconstnode(n).value.uvalue and $ff);
ca:=@ch;
len:=1;
end
else
begin
Message(parser_e_illegal_expression);
len:=0;
{ avoid crash later on }
ch[0]:=#0;
ca:=@ch;
end;
if len>(def.highrange-def.lowrange+1) then
Message(parser_e_string_larger_array);
for i:=0 to def.highrange-def.lowrange do
begin
if i<len then
begin
tc_emit_arr_strconst_ele(pbyte(ca)^,torddef(cansichartype));
inc(ca);
end
else
{Fill the remaining positions with #0.}
tc_emit_arr_strconst_ele(0,torddef(cansichartype));
end;
n.free;
end;
if length(arrstringdata.arrstring)<>0 then
tc_flush_arr_strconst(def.elementdef);
arrstringdata.arraybase.free;
@ -158,8 +261,6 @@ implementation
procedure tjvmtypedconstbuilder.tc_emit_orddef(def: torddef; var node: tnode);
var
elesize: longint;
begin
if not parsingordarray then
begin
@ -168,34 +269,7 @@ implementation
end;
if node.nodetype<>ordconstn then
internalerror(2011111101);
elesize:=def.size;
inc(arrstringdata.arrdatalen);
case elesize of
1:
arrstringdata.arrstring:=arrstringdata.arrstring+char(tordconstnode(node).value.svalue);
2:
arrstringdata.arrstring:=arrstringdata.arrstring+char(tordconstnode(node).value.svalue shr 8)+char(tordconstnode(node).value.svalue and $ff);
4:
arrstringdata.arrstring:=arrstringdata.arrstring+char((tordconstnode(node).value.svalue shr 24))+
char((tordconstnode(node).value.svalue shr 16) and $ff)+
char((tordconstnode(node).value.svalue shr 8) and $ff)+
char(tordconstnode(node).value.svalue and $ff);
8:
arrstringdata.arrstring:=arrstringdata.arrstring+char((tordconstnode(node).value.svalue shr 56))+
char((tordconstnode(node).value.svalue shr 48) and $ff)+
char((tordconstnode(node).value.svalue shr 40) and $ff)+
char((tordconstnode(node).value.svalue shr 32) and $ff)+
char((tordconstnode(node).value.svalue shr 24) and $ff)+
char((tordconstnode(node).value.svalue shr 16) and $ff)+
char((tordconstnode(node).value.svalue shr 8) and $ff)+
char(tordconstnode(node).value.svalue and $ff);
end;
{ we can't use the full 64kb, because inside the Java class file the
string constant is actually encoded using UTF-8 and it's this UTF-8
encoding that has to fit inside 64kb (and utf-8 encoding of random
data can easily blow up its size by about a third) }
if length(arrstringdata.arrstring)>40000 then
tc_flush_arr_strconst(def);
tc_emit_arr_strconst_ele(tordconstnode(node).value.svalue,def);
basenode.free;
basenode:=nil;
node.free;

1
rtl/java/jtcon.inc
View File

@ -73,6 +73,7 @@ procedure fpc_tcon_int64_array_from_string(const s: unicodestring; var arr: arra
{ specifying compilerprocs using an external name doesn't work yet }
procedure fpc_tcon_shortint_array_from_string_intern_as_byte(const s: unicodestring; var arr: array of byte; startindex, len: longint); external name 'fpc_tcon_shortint_array_from_string';
procedure fpc_tcon_ansichar_array_from_string(const s: unicodestring; var arr: array of ansichar; startindex, len: longint); external name 'fpc_tcon_shortint_array_from_string';
procedure fpc_tcon_smallint_array_from_string_intern_as_word(const s: unicodestring; var arr: array of word; startindex, len: longint); external name 'fpc_tcon_smallint_array_from_string';
procedure fpc_tcon_longint_array_from_string_intern_as_cardinal(const s: unicodestring; var arr: array of cardinal; startindex, len: longint); external name 'fpc_tcon_longint_array_from_string';
procedure fpc_tcon_int64_array_from_string_intern_as_int64(const s: unicodestring; var arr: array of qword; startindex, len: longint); external name 'fpc_tcon_int64_array_from_string';

1
rtl/java/jtconh.inc
View File

@ -17,6 +17,7 @@
procedure fpc_tcon_shortint_array_from_string(const s: unicodestring; var arr: array of shortint; startindex, len: longint); compilerproc;
procedure fpc_tcon_byte_array_from_string(const s: unicodestring; var arr: array of byte; startindex, len: longint); compilerproc;
procedure fpc_tcon_ansichar_array_from_string(const s: unicodestring; var arr: array of ansichar; startindex, len: longint); compilerproc;
procedure fpc_tcon_smallint_array_from_string(const s: unicodestring; var arr: array of smallint; startindex, len: longint); compilerproc;
procedure fpc_tcon_word_array_from_string(const s: unicodestring; var arr: array of word; startindex, len: longint); compilerproc;