1 {
2     Copyright (c) 2011 by Jonas Maebe
3 
4     Generates nodes for typed constant declarations
5 
6     This program is free software; you can redistribute it and/or modify
7     it under the terms of the GNU General Public License as published by
8     the Free Software Foundation; either version 2 of the License, or
9     (at your option) any later version.
10 
11     This program is distributed in the hope that it will be useful,
12     but WITHOUT ANY WARRANTY; without even the implied warranty of
13     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14     GNU General Public License for more details.
15 
16     You should have received a copy of the GNU General Public License
17     along with this program; if not, write to the Free Software
18     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
19 
20  ****************************************************************************
21 }
22 unit njvmtcon;
23 
24 {$i fpcdefs.inc}
25 
26 interface
27 
28     uses
29       globtype,
30       node,
31       symtype,symdef,
32       ngtcon;
33 
34 
35     type
36       tarrstringdata = record
37         arrstring: ansistring;
38         arrdatastart, arrdatalen: asizeint;
39         arraybase: tnode;
40       end;
41 
42       tjvmtypedconstbuilder = class(tnodetreetypedconstbuilder)
43        private
44         procedure tc_flush_arr_strconst(def: tdef);
45         procedure tc_emit_arr_strconst_ele(val: int64; def: torddef);
46        protected
47         arrstringdata: tarrstringdata;
48         parsingordarray: boolean;
49 
50         procedure parse_arraydef(def: tarraydef); override;
51         procedure tc_emit_setdef(def: tsetdef; var node: tnode);override;
52         procedure tc_emit_orddef(def: torddef; var node: tnode); override;
53       end;
54 
55 implementation
56 
57     uses
58       globals,widestr,verbose,constexp,
59       tokens,scanner,pexpr,
60       defutil,
61       nbas,ncal,ncon,ncnv,njvmcon;
62 
63 
64     procedure init_arrstringdata(out data: tarrstringdata);
65       begin
66         data.arrstring:='';
67         data.arrdatastart:=0;
68         data.arrdatalen:=0;
69         data.arraybase:=nil;
70       end;
71 
72 
73     procedure tjvmtypedconstbuilder.tc_flush_arr_strconst(def: tdef);
74       var
75         wstr: pcompilerwidestring;
76         wc: tcompilerwidechar;
77         i: longint;
78         procvariant: string[8];
79       begin
80         // convert ansistring to packed unicodestring
81         initwidestring(wstr);
82         for i:=1 to length(arrstringdata.arrstring) div 2 do
83           begin
84             wc:=tcompilerwidechar(ord(arrstringdata.arrstring[i*2-1]) shl 8 or
85                                   ord(arrstringdata.arrstring[i*2]));
86             concatwidestringchar(wstr,wc);
87           end;
88         if odd(length(arrstringdata.arrstring)) then
89           concatwidestringchar(wstr,
90             tcompilerwidechar(ord(arrstringdata.arrstring[length(arrstringdata.arrstring)]) shl 8));
91 
92 
93         if is_char(def) then
94           procvariant:='ansichar'
95         else if is_signed(def) then
96           case def.size of
97             1: procvariant:='shortint';
98             2: procvariant:='smallint';
99             4: procvariant:='longint';
100             8: procvariant:='int64';
101             else
102               internalerror(2011111301);
103           end
104         else
105           case def.size of
106             1: procvariant:='byte';
107             2: procvariant:='word';
108             4: procvariant:='cardinal';
109             8: procvariant:='qword';
110             else
111               internalerror(2011111302);
112           end;
113         // (const s: unicodestring; var arr: array of shortint; startintdex, len: longint);
114         addstatement(statmnt,ccallnode.createintern('fpc_tcon_'+procvariant+'_array_from_string',
115           ccallparanode.create(genintconstnode(arrstringdata.arrdatalen),
116             ccallparanode.create(genintconstnode(arrstringdata.arrdatastart),
117               ccallparanode.create(arrstringdata.arraybase.getcopy,
118                 ccallparanode.create(cstringconstnode.createunistr(wstr),nil))))));
119 
120         inc(arrstringdata.arrdatastart,arrstringdata.arrdatalen);
121         arrstringdata.arrstring:='';
122         arrstringdata.arrdatalen:=0;
123 
124         donewidestring(wstr);
125       end;
126 
127 
128     procedure tjvmtypedconstbuilder.tc_emit_arr_strconst_ele(val: int64; def: torddef);
129       var
130         elesize: longint;
131       begin
132         elesize:=def.size;
133         inc(arrstringdata.arrdatalen);
134         case elesize of
135           1:
136             arrstringdata.arrstring:=arrstringdata.arrstring+char(val);
137           2:
138             arrstringdata.arrstring:=arrstringdata.arrstring+char(val shr 8)+char(val and $ff);
139           4:
140             arrstringdata.arrstring:=arrstringdata.arrstring+char((val shr 24))+
141               char((val shr 16) and $ff)+
142               char((val shr 8) and $ff)+
143               char(val and $ff);
144           8:
145             arrstringdata.arrstring:=arrstringdata.arrstring+char((val shr 56))+
146               char((val shr 48) and $ff)+
147               char((val shr 40) and $ff)+
148               char((val shr 32) and $ff)+
149               char((val shr 24) and $ff)+
150               char((val shr 16) and $ff)+
151               char((val shr 8) and $ff)+
152               char(val and $ff);
153         end;
154         { we can't use the full 64kb, because inside the Java class file the
155           string constant is actually encoded using UTF-8 and it's this UTF-8
156           encoding that has to fit inside 64kb (and utf-8 encoding of random
157           data can easily blow up its size by about a third) }
158         if length(arrstringdata.arrstring)>40000 then
159           tc_flush_arr_strconst(def);
160       end;
161 
162 
163     procedure tjvmtypedconstbuilder.parse_arraydef(def: tarraydef);
164       var
165         n: tnode;
166         i, len: longint;
167         ca: pbyte;
168         ch: array[0..1] of char;
169         old_arrstringdata: tarrstringdata;
170         old_parsingordarray: boolean;
171       begin
172         if is_dynamic_array(def) or
173            (not is_char(def.elementdef) and
174             (not is_integer(def.elementdef) or
175              not(ts_compact_int_array_init in current_settings.targetswitches))) then
176           begin
177             inherited;
178             exit;
179           end;
180         old_arrstringdata:=arrstringdata;
181         init_arrstringdata(arrstringdata);
182         arrstringdata.arraybase:=basenode.getcopy;
183         old_parsingordarray:=parsingordarray;
184         parsingordarray:=true;
185         if (token=_LKLAMMER) or
186            not is_char(def.elementdef) then
187           inherited
188         else
189           begin
190             { array of ansichar -> can be constant char/string; can't use plain
191               assignment in this case, because it will result in a codepage
192               conversion }
193             n:=comp_expr([ef_accept_equal]);
194             if n.nodetype=stringconstn then
195               begin
196                 len:=tstringconstnode(n).len;
197                 if (tstringconstnode(n).cst_type in [cst_unicodestring,cst_widestring]) then
198                   inserttypeconv(n,getansistringdef);
199                   if n.nodetype<>stringconstn then
200                     internalerror(2010033003);
201                   ca:=pbyte(tstringconstnode(n).value_str);
202                 { For tp7 the maximum lentgh can be 255 }
203                 if (m_tp7 in current_settings.modeswitches) and
204                    (len>255) then
205                  len:=255;
206               end
207             else if is_constcharnode(n) then
208                begin
209                  ch[0]:=chr(tordconstnode(n).value.uvalue and $ff);
210                  ca:=@ch;
211                  len:=1;
212                end
213             else if is_constwidecharnode(n) and (current_settings.sourcecodepage<>CP_UTF8) then
214                begin
215                  inserttypeconv(n,cansichartype);
216                  if not is_constcharnode(n) then
217                    internalerror(2010033001);
218                  ch[0]:=chr(tordconstnode(n).value.uvalue and $ff);
219                  ca:=@ch;
220                  len:=1;
221                end
222             else
223               begin
224                 Message(parser_e_illegal_expression);
225                 len:=0;
226                 { avoid crash later on }
227                 ch[0]:=#0;
228                 ca:=@ch;
229               end;
230             if len>(def.highrange-def.lowrange+1) then
231               Message(parser_e_string_larger_array);
232             for i:=0 to def.highrange-def.lowrange do
233               begin
234                 if i<len then
235                   begin
236                     tc_emit_arr_strconst_ele(pbyte(ca)^,torddef(cansichartype));
237                     inc(ca);
238                   end
239                 else
240                   {Fill the remaining positions with #0.}
241                   tc_emit_arr_strconst_ele(0,torddef(cansichartype));
242               end;
243             n.free;
244           end;
245         if length(arrstringdata.arrstring)<>0 then
246           tc_flush_arr_strconst(def.elementdef);
247         arrstringdata.arraybase.free;
248         parsingordarray:=old_parsingordarray;
249         arrstringdata:=old_arrstringdata;
250       end;
251 
252 
253     procedure tjvmtypedconstbuilder.tc_emit_setdef(def: tsetdef; var node: tnode);
254       begin
255         { indicate that set constant nodes have to be transformed into
256           constructors here }
257         if node.nodetype=setconstn then
258           tjvmsetconstnode(node).setconsttype:=sct_construct;
259         inherited tc_emit_setdef(def,node);
260       end;
261 
262 
263     procedure tjvmtypedconstbuilder.tc_emit_orddef(def: torddef; var node: tnode);
264       begin
265         if not parsingordarray then
266           begin
267             inherited;
268             exit;
269           end;
270         if node.nodetype<>ordconstn then
271           internalerror(2011111101);
272         tc_emit_arr_strconst_ele(tordconstnode(node).value.svalue,def);
273         basenode.free;
274         basenode:=nil;
275         node.free;
276         node:=nil;
277       end;
278 
279 begin
280   ctypedconstbuilder:=tjvmtypedconstbuilder;
281 end.
282