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