1 {
2 Copyright (c) 1998-2011 by Florian Klaempfl, Jonas Maebe
3
4 Generates code/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 ngtcon;
23
24 {$i fpcdefs.inc}
25
26 interface
27
28 uses
29 globtype,cclasses,constexp,
30 aasmbase,aasmdata,aasmtai,aasmcnst,
31 node,nbas,
32 symconst, symtype, symbase, symdef,symsym;
33
34
35 type
36 ttypedconstbuilder = class
37 protected
38 current_old_block_type : tblock_type;
39 tcsym: tstaticvarsym;
40
41 { this procedure reads typed constants }
42 procedure read_typed_const_data(def:tdef);
43
44 procedure parse_orddef(def: torddef);
45 procedure parse_floatdef(def: tfloatdef);
46 procedure parse_classrefdef(def: tclassrefdef);
47 procedure parse_pointerdef(def: tpointerdef);
48 procedure parse_setdef(def: tsetdef);
49 procedure parse_enumdef(def: tenumdef);
50 procedure parse_stringdef(def: tstringdef);
51 procedure parse_arraydef(def:tarraydef);virtual;abstract;
52 procedure parse_procvardef(def:tprocvardef);virtual;abstract;
53 procedure parse_recorddef(def:trecorddef);virtual;abstract;
54 procedure parse_objectdef(def:tobjectdef);virtual;abstract;
55
56 procedure tc_emit_orddef(def: torddef; var node: tnode);virtual;abstract;
57 procedure tc_emit_floatdef(def: tfloatdef; var node: tnode);virtual;abstract;
58 procedure tc_emit_classrefdef(def: tclassrefdef; var node: tnode);virtual;abstract;
59 procedure tc_emit_pointerdef(def: tpointerdef; var node: tnode);virtual;abstract;
60 procedure tc_emit_setdef(def: tsetdef; var node: tnode);virtual;abstract;
61 procedure tc_emit_enumdef(def: tenumdef; var node: tnode);virtual;abstract;
62 procedure tc_emit_stringdef(def: tstringdef; var node: tnode);virtual;abstract;
63 public
64 constructor create(sym: tstaticvarsym);
65 end;
66 ttypedconstbuilderclass = class of ttypedconstbuilder;
67
68
69 { should be changed into nested type of tasmlisttypedconstbuilder when
70 possible }
71 tbitpackedval = record
72 curval, nextval: aword;
73 curbitoffset: smallint;
74 packedbitsize: byte;
75 end;
76
77 tasmlisttypedconstbuilder = class(ttypedconstbuilder)
78 private
79 fsym: tstaticvarsym;
80 curoffset: asizeint;
81
parse_single_packed_constnull82 function parse_single_packed_const(def: tdef; var bp: tbitpackedval): boolean;
83 procedure flush_packed_value(var bp: tbitpackedval);
84 protected
85 ftcb: ttai_typedconstbuilder;
86 fdatalist: tasmlist;
87
88 procedure parse_packed_array_def(def: tarraydef);
89 procedure parse_arraydef(def:tarraydef);override;
90 procedure parse_procvardef(def:tprocvardef);override;
91 procedure parse_recorddef(def:trecorddef);override;
92 procedure parse_objectdef(def:tobjectdef);override;
93
94 procedure tc_emit_orddef(def: torddef; var node: tnode);override;
95 procedure tc_emit_floatdef(def: tfloatdef; var node: tnode); override;
96 procedure tc_emit_classrefdef(def: tclassrefdef; var node: tnode);override;
97 procedure tc_emit_pointerdef(def: tpointerdef; var node: tnode);override;
98 procedure tc_emit_setdef(def: tsetdef; var node: tnode);override;
99 procedure tc_emit_enumdef(def: tenumdef; var node: tnode);override;
100 procedure tc_emit_stringdef(def: tstringdef; var node: tnode);override;
101 public
102 constructor create(sym: tstaticvarsym);virtual;
103 destructor Destroy; override;
104 procedure parse_into_asmlist;
105 { the asmlist containing the definition of the parsed entity and another
106 one containing the data generated for that same entity (e.g. the
107 string data referenced by an ansistring constant) }
108 procedure get_final_asmlists(out reslist, datalist: tasmlist);
109 end;
110 tasmlisttypedconstbuilderclass = class of tasmlisttypedconstbuilder;
111
112 tnodetreetypedconstbuilder = class(ttypedconstbuilder)
113 protected
114 resultblock: tblocknode;
115 statmnt: tstatementnode;
116
117 { when parsing a record, the base nade becomes a loadnode of the record,
118 etc. }
119 basenode: tnode;
120
121 procedure parse_arraydef(def:tarraydef);override;
122 procedure parse_procvardef(def:tprocvardef);override;
123 procedure parse_recorddef(def:trecorddef);override;
124 procedure parse_objectdef(def:tobjectdef);override;
125
126 procedure tc_emit_orddef(def: torddef; var node: tnode);override;
127 procedure tc_emit_floatdef(def: tfloatdef; var node: tnode); override;
128 procedure tc_emit_classrefdef(def: tclassrefdef; var node: tnode);override;
129 procedure tc_emit_pointerdef(def: tpointerdef; var node: tnode);override;
130 procedure tc_emit_setdef(def: tsetdef; var node: tnode);override;
131 procedure tc_emit_enumdef(def: tenumdef; var node: tnode);override;
132 procedure tc_emit_stringdef(def: tstringdef; var node: tnode);override;
133 public
134 constructor create(sym: tstaticvarsym; previnit: tnode);virtual;
135 destructor destroy;override;
parse_into_nodetreenull136 function parse_into_nodetree: tnode;
137 end;
138 tnodetreetypedconstbuilderclass = class of tnodetreetypedconstbuilder;
139
140 var
141 ctypedconstbuilder: ttypedconstbuilderclass;
142
143 implementation
144
145 uses
146 SysUtils,
147 systems,tokens,verbose,compinnr,
148 cutils,globals,widestr,scanner,
149 symtable,
150 defutil,defcmp,
151 { pass 1 }
152 htypechk,procinfo,
153 nmem,ncnv,ninl,ncon,nld,
154 { parser specific stuff }
155 pbase,pexpr,
156 { codegen }
157 cpuinfo,cgbase,
158 wpobase
159 ;
160
161 {$maxfpuregisters 0}
162
get_next_varsymnull163 function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectList; var symidx:longint):tsym;inline;
164 begin
165 while symidx<SymList.Count do
166 begin
167 result:=tsym(def.symtable.SymList[symidx]);
168 inc(symidx);
169 if (result.typ=fieldvarsym) and
170 not(sp_static in result.symoptions) then
171 exit;
172 end;
173 result:=nil;
174 end;
175
176
177 {*****************************************************************************
178 read typed const
179 *****************************************************************************}
180
181 procedure ttypedconstbuilder.parse_orddef(def:torddef);
182 var
183 n : tnode;
184 begin
185 n:=comp_expr([ef_accept_equal]);
186 { for C-style booleans, true=-1 and false=0) }
187 if is_cbool(def) then
188 inserttypeconv(n,def);
189 tc_emit_orddef(def,n);
190 n.free;
191 end;
192
193 procedure ttypedconstbuilder.parse_floatdef(def:tfloatdef);
194 var
195 n : tnode;
196 begin
197 n:=comp_expr([ef_accept_equal]);
198 tc_emit_floatdef(def,n);
199 n.free;
200 end;
201
202 procedure ttypedconstbuilder.parse_classrefdef(def:tclassrefdef);
203 var
204 n : tnode;
205 begin
206 n:=comp_expr([ef_accept_equal]);
207 case n.nodetype of
208 loadvmtaddrn:
209 begin
210 { update wpo info }
211 if not assigned(current_procinfo) or
212 (po_inline in current_procinfo.procdef.procoptions) or
213 wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname) then
214 tobjectdef(tclassrefdef(n.resultdef).pointeddef).register_maybe_created_object_type;
215 end;
216 end;
217 tc_emit_classrefdef(def,n);
218 n.free;
219 end;
220
221 procedure ttypedconstbuilder.parse_pointerdef(def:tpointerdef);
222 var
223 p: tnode;
224 begin
225 p:=comp_expr([ef_accept_equal]);
226 tc_emit_pointerdef(def,p);
227 p.free;
228 end;
229
230 procedure ttypedconstbuilder.parse_setdef(def:tsetdef);
231 var
232 p : tnode;
233 begin
234 p:=comp_expr([ef_accept_equal]);
235 tc_emit_setdef(def,p);
236 p.free;
237 end;
238
239 procedure ttypedconstbuilder.parse_enumdef(def:tenumdef);
240 var
241 p : tnode;
242 begin
243 p:=comp_expr([ef_accept_equal]);
244 tc_emit_enumdef(def,p);
245 p.free;
246 end;
247
248 procedure ttypedconstbuilder.parse_stringdef(def:tstringdef);
249 var
250 n : tnode;
251 begin
252 n:=comp_expr([ef_accept_equal]);
253 tc_emit_stringdef(def,n);
254 n.free;
255 end;
256
257 { ttypedconstbuilder }
258
259 procedure ttypedconstbuilder.read_typed_const_data(def:tdef);
260 var
261 prev_old_block_type,
262 old_block_type: tblock_type;
263 begin
264 old_block_type:=block_type;
265 prev_old_block_type:=current_old_block_type;
266 current_old_block_type:=old_block_type;
267 block_type:=bt_const;
268 case def.typ of
269 orddef :
270 parse_orddef(torddef(def));
271 floatdef :
272 parse_floatdef(tfloatdef(def));
273 classrefdef :
274 parse_classrefdef(tclassrefdef(def));
275 pointerdef :
276 parse_pointerdef(tpointerdef(def));
277 setdef :
278 parse_setdef(tsetdef(def));
279 enumdef :
280 parse_enumdef(tenumdef(def));
281 stringdef :
282 parse_stringdef(tstringdef(def));
283 arraydef :
284 parse_arraydef(tarraydef(def));
285 procvardef:
286 parse_procvardef(tprocvardef(def));
287 recorddef:
288 parse_recorddef(trecorddef(def));
289 objectdef:
290 parse_objectdef(tobjectdef(def));
291 errordef:
292 begin
293 { try to consume something useful }
294 if token=_LKLAMMER then
295 consume_all_until(_RKLAMMER)
296 else
297 consume_all_until(_SEMICOLON);
298 end;
299 else
300 Message(parser_e_type_const_not_possible);
301 end;
302 block_type:=old_block_type;
303 current_old_block_type:=prev_old_block_type;
304 end;
305
306
307 constructor ttypedconstbuilder.create(sym: tstaticvarsym);
308 begin
309 tcsym:=sym;
310 end;
311
312
313 {*****************************************************************************
314 Bitpacked value helpers
315 *****************************************************************************}
316
317 procedure initbitpackval(out bp: tbitpackedval; packedbitsize: byte);
318 begin
319 bp.curval:=0;
320 bp.nextval:=0;
321 bp.curbitoffset:=0;
322 bp.packedbitsize:=packedbitsize;
323 end;
324
325
326 {$push}
327 {$r-}
328 {$q-}
329 { (values between quotes below refer to fields of bp; fields not }
330 { mentioned are unused by this routine) }
331 { bitpacks "value" as bitpacked value of bitsize "packedbitsize" into }
332 { "curval", which has already been filled up to "curbitoffset", and }
333 { stores the spillover if any into "nextval". It also updates }
334 { curbitoffset to reflect how many bits of currval are now used (can be }
335 { > AIntBits in case of spillover) }
336 procedure bitpackval(value: aword; var bp: tbitpackedval);
337 var
338 shiftcount: longint;
339 begin
340 if (target_info.endian=endian_big) then
341 begin
342 { bitpacked format: left-aligned (i.e., "big endian bitness") }
343 { work around broken x86 shifting }
344 if (AIntBits<>bp.packedbitsize) and
345 (bp.curbitoffset<AIntBits) then
346 bp.curval:=bp.curval or ((value shl (AIntBits-bp.packedbitsize)) shr bp.curbitoffset);
347 shiftcount:=((AIntBits-bp.packedbitsize)-bp.curbitoffset);
348 { carry-over to the next element? }
349 if (shiftcount<0) then
350 begin
351 if shiftcount>=AIntBits then
352 bp.nextval:=(value and ((aword(1) shl (-shiftcount))-1)) shl
353 (AIntBits+shiftcount)
354 else
355 bp.nextval:=0
356 end
357 end
358 else
359 begin
360 { bitpacked format: right aligned (i.e., "little endian bitness") }
361 { work around broken x86 shifting }
362 if bp.curbitoffset<AIntBits then
363 bp.curval:=bp.curval or (value shl bp.curbitoffset);
364 { carry-over to the next element? }
365 if (bp.curbitoffset+bp.packedbitsize>AIntBits) then
366 if bp.curbitoffset>0 then
367 bp.nextval:=value shr (AIntBits-bp.curbitoffset)
368 else
369 bp.nextval:=0;
370 end;
371 inc(bp.curbitoffset,bp.packedbitsize);
372 end;
373
374 procedure tasmlisttypedconstbuilder.flush_packed_value(var bp: tbitpackedval);
375 var
376 bitstowrite: longint;
377 writeval : {$ifdef CPU8BITALU}smallint{$else}aint{$endif};
378 begin
379 if (bp.curbitoffset < AIntBits) then
380 begin
381 { forced flush -> write multiple of a byte }
382 bitstowrite:=align(bp.curbitoffset,8);
383 bp.curbitoffset:=0;
384 end
385 else
386 begin
387 bitstowrite:=AIntBits;
388 dec(bp.curbitoffset,AIntBits);
389 end;
390 while (bitstowrite>=8) do
391 begin
392 if (target_info.endian=endian_little) then
393 begin
394 { write lowest byte }
395 writeval:=byte(bp.curval);
396 bp.curval:=bp.curval shr 8;
397 end
398 else
399 begin
400 { write highest byte }
401 writeval:=bp.curval shr (AIntBits-8);
402 {$push}{$r-,q-}
403 bp.curval:=bp.curval shl 8;
404 {$pop}
405 end;
406 ftcb.emit_tai(tai_const.create_8bit(writeval),u8inttype);
407 dec(bitstowrite,8);
408 end;
409 bp.curval:=bp.nextval;
410 bp.nextval:=0;
411 end;
412
413 {$pop}
414
415
416 { parses a packed array constant }
417 procedure tasmlisttypedconstbuilder.parse_packed_array_def(def: tarraydef);
418 var
419 i : {$ifdef CPU8BITALU}smallint{$else}aint{$endif};
420 bp : tbitpackedval;
421 begin
422 if not(def.elementdef.typ in [orddef,enumdef]) then
423 internalerror(2007022010);
424 ftcb.maybe_begin_aggregate(def);
425 { begin of the array }
426 consume(_LKLAMMER);
427 initbitpackval(bp,def.elepackedbitsize);
428 i:=def.lowrange;
429 { can't use for-loop, fails when cross-compiling from }
430 { 32 to 64 bit because i is then 64 bit }
431 while (i<def.highrange) do
432 begin
433 { get next item of the packed array }
434 if not parse_single_packed_const(def.elementdef,bp) then
435 exit;
436 consume(_COMMA);
437 inc(i);
438 end;
439 { final item }
440 if not parse_single_packed_const(def.elementdef,bp) then
441 exit;
442 { flush final incomplete value if necessary }
443 if (bp.curbitoffset <> 0) then
444 flush_packed_value(bp);
445 ftcb.maybe_end_aggregate(def);
446 consume(_RKLAMMER);
447 end;
448
449
450
451 constructor tasmlisttypedconstbuilder.create(sym: tstaticvarsym);
452 begin
453 inherited;
454 fsym:=sym;
455 ftcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable,tcalo_apply_constalign]);
456 fdatalist:=tasmlist.create;
457 curoffset:=0;
458 end;
459
460
461 destructor tasmlisttypedconstbuilder.Destroy;
462 begin
463 fdatalist.free;
464 ftcb.free;
465 inherited Destroy;
466 end;
467
468
469 procedure tasmlisttypedconstbuilder.tc_emit_stringdef(def: tstringdef; var node: tnode);
470 var
471 strlength : {$ifdef CPU8BITALU}smallint{$else}aint{$endif};
472 strval : pchar;
473 ll : tasmlabofs;
474 ca : pchar;
475 winlike : boolean;
476 hsym : tconstsym;
477 begin
478 strval:='';
479 { load strval and strlength of the constant tree }
480 if (node.nodetype=stringconstn) or is_wide_or_unicode_string(def) or is_constwidecharnode(node) or
481 ((node.nodetype=typen) and is_interfacecorba(ttypenode(node).typedef)) or
482 is_constcharnode(node) then
483 begin
484 { convert to the expected string type so that
485 for widestrings strval is a pcompilerwidestring }
486 inserttypeconv(node,def);
487 if (not codegenerror) and
488 (node.nodetype=stringconstn) then
489 begin
490 strlength:=tstringconstnode(node).len;
491 strval:=tstringconstnode(node).value_str;
492 { the def may have changed from e.g. RawByteString to
493 AnsiString(CP_ACP) }
494 if node.resultdef.typ=stringdef then
495 def:=tstringdef(node.resultdef)
496 else
497 internalerror(2014010501);
498 end
499 else
500 begin
501 { an error occurred trying to convert the result to a string }
502 strlength:=-1;
503 { it's possible that the type conversion could not be
504 evaluated at compile-time }
505 if not codegenerror then
506 CGMessage(parser_e_widestring_to_ansi_compile_time);
507 end;
508 end
509 else if is_constresourcestringnode(node) then
510 begin
511 hsym:=tconstsym(tloadnode(node).symtableentry);
512 strval:=pchar(hsym.value.valueptr);
513 strlength:=hsym.value.len;
514 { Delphi-compatible (mis)feature:
515 Link AnsiString constants to their initializing resourcestring,
516 enabling them to be (re)translated at runtime.
517 Wide/UnicodeString are currently rejected above (with incorrect error message).
518 ShortStrings cannot be handled unless another table is built for them;
519 considering this acceptable, because Delphi rejects them altogether.
520 }
521 if (not is_shortstring(def)) and
522 ((tcsym.owner.symtablelevel<=main_program_level) or
523 (current_old_block_type=bt_const)) then
524 begin
525 current_asmdata.ResStrInits.Concat(
526 TTCInitItem.Create(tcsym,curoffset,
527 current_asmdata.RefAsmSymbol(make_mangledname('RESSTR',hsym.owner,hsym.name),AT_DATA),charpointertype)
528 );
529 Include(tcsym.varoptions,vo_force_finalize);
530 end;
531 end
532 else
533 begin
534 Message(parser_e_illegal_expression);
535 strlength:=-1;
536 end;
537 if strlength>=0 then
538 begin
539 case def.stringtype of
540 st_shortstring:
541 begin
542 ftcb.maybe_begin_aggregate(def);
543 if strlength>=def.size then
544 begin
545 message2(parser_w_string_too_long,strpas(strval),tostr(def.size-1));
546 strlength:=def.size-1;
547 end;
548 ftcb.emit_tai(Tai_const.Create_8bit(strlength),cansichartype);
549 { room for the string data + terminating #0 }
550 getmem(ca,def.size);
551 move(strval^,ca^,strlength);
552 { zero-terminate and fill with spaces if size is shorter }
553 fillchar(ca[strlength],def.size-strlength-1,' ');
554 ca[strlength]:=#0;
555 ca[def.size-1]:=#0;
556 ftcb.emit_tai(Tai_string.Create_pchar(ca,def.size-1),carraydef.getreusable(cansichartype,def.size-1));
557 ftcb.maybe_end_aggregate(def);
558 end;
559 st_ansistring:
560 begin
561 { an empty ansi string is nil! }
562 if (strlength=0) then
563 begin
564 ll.lab:=nil;
565 ll.ofs:=0;
566 end
567 else
568 ll:=ftcb.emit_ansistring_const(fdatalist,strval,strlength,def.encoding);
569 ftcb.emit_string_offset(ll,strlength,def.stringtype,false,charpointertype);
570 end;
571 st_unicodestring,
572 st_widestring:
573 begin
574 { an empty wide/unicode string is nil! }
575 if (strlength=0) then
576 begin
577 ll.lab:=nil;
578 ll.ofs:=0;
579 winlike:=false;
580 end
581 else
582 begin
583 winlike:=(def.stringtype=st_widestring) and (tf_winlikewidestring in target_info.flags);
584 ll:=ftcb.emit_unicodestring_const(fdatalist,
585 strval,
586 def.encoding,
587 winlike);
588
589 { Collect Windows widestrings that need initialization at startup.
590 Local initialized vars are excluded because they are initialized
591 at function entry instead. }
592 if winlike and
593 ((tcsym.owner.symtablelevel<=main_program_level) or
594 (current_old_block_type=bt_const)) then
595 begin
596 if ll.ofs<>0 then
597 internalerror(2012051704);
598 current_asmdata.WideInits.Concat(
599 TTCInitItem.Create(tcsym,curoffset,ll.lab,widecharpointertype)
600 );
601 ll.lab:=nil;
602 ll.ofs:=0;
603 Include(tcsym.varoptions,vo_force_finalize);
604 end;
605 end;
606 ftcb.emit_string_offset(ll,strlength,def.stringtype,winlike,widecharpointertype);
607 end;
608 else
609 internalerror(200107081);
610 end;
611 end;
612 end;
613
614
615 procedure tasmlisttypedconstbuilder.tc_emit_orddef(def: torddef; var node: tnode);
616 var
617 intvalue: tconstexprint;
618
619 procedure do_error;
620 begin
621 if is_constnode(node) then
622 IncompatibleTypes(node.resultdef, def)
623 else if not(parse_generic) then
624 Message(parser_e_illegal_expression);
625 end;
626
627 begin
628 case def.ordtype of
629 pasbool1,
630 pasbool8,
631 bool8bit,
632 pasbool16,
633 bool16bit,
634 pasbool32,
635 bool32bit,
636 pasbool64,
637 bool64bit:
638 begin
639 if is_constboolnode(node) then
640 begin
641 adaptrange(def,tordconstnode(node).value,false,false,cs_check_range in current_settings.localswitches);
642 ftcb.emit_ord_const(tordconstnode(node).value.svalue,def)
643 end
644 else
645 do_error;
646 end;
647 uchar :
648 begin
649 if is_constwidecharnode(node) then
650 inserttypeconv(node,cansichartype);
651 if is_constcharnode(node) or
652 ((m_delphi in current_settings.modeswitches) and
653 is_constwidecharnode(node) and
654 (tordconstnode(node).value <= 255)) then
655 ftcb.emit_ord_const(byte(tordconstnode(node).value.svalue),def)
656 else
657 do_error;
658 end;
659 uwidechar :
660 begin
661 if is_constcharnode(node) then
662 inserttypeconv(node,cwidechartype);
663 if is_constwidecharnode(node) then
664 ftcb.emit_ord_const(word(tordconstnode(node).value.svalue),def)
665 else
666 do_error;
667 end;
668 s8bit,u8bit,
669 u16bit,s16bit,
670 s32bit,u32bit,
671 s64bit,u64bit :
672 begin
673 if is_constintnode(node) then
674 begin
675 adaptrange(def,tordconstnode(node).value,false,false,cs_check_range in current_settings.localswitches);
676 ftcb.emit_ord_const(tordconstnode(node).value.svalue,def);
677 end
678 else
679 do_error;
680 end;
681 scurrency:
682 begin
683 if is_constintnode(node) then
684 intvalue:=tordconstnode(node).value*10000
685 { allow bootstrapping }
686 else if is_constrealnode(node) then
687 intvalue:=PInt64(@trealconstnode(node).value_currency)^
688 else
689 begin
690 intvalue:=0;
691 IncompatibleTypes(node.resultdef, def);
692 end;
693 ftcb.emit_ord_const(intvalue,def);
694 end;
695 else
696 internalerror(200611052);
697 end;
698 end;
699
700
701 procedure tasmlisttypedconstbuilder.tc_emit_floatdef(def: tfloatdef; var node: tnode);
702 var
703 value : bestreal;
704 begin
705 value:=0.0;
706 if is_constrealnode(node) then
707 value:=trealconstnode(node).value_real
708 else if is_constintnode(node) then
709 value:=tordconstnode(node).value
710 else if is_constnode(node) then
711 IncompatibleTypes(node.resultdef, def)
712 else
713 Message(parser_e_illegal_expression);
714
715 case def.floattype of
716 s32real :
717 ftcb.emit_tai(tai_realconst.create_s32real(ts32real(value)),def);
718 s64real :
719 {$ifdef ARM}
720 if is_double_hilo_swapped then
721 ftcb.emit_tai(tai_realconst.create_s64real_hiloswapped(ts64real(value)),def)
722 else
723 {$endif ARM}
724 ftcb.emit_tai(tai_realconst.create_s64real(ts64real(value)),def);
725 s80real :
726 ftcb.emit_tai(tai_realconst.create_s80real(value,s80floattype.size),def);
727 sc80real :
728 ftcb.emit_tai(tai_realconst.create_s80real(value,sc80floattype.size),def);
729 s64comp :
730 { the round is necessary for native compilers where comp isn't a float }
731 ftcb.emit_tai(tai_realconst.create_s64compreal(round(value)),def);
732 s64currency:
733 ftcb.emit_tai(tai_realconst.create_s64compreal(round(value*10000)),def);
734 s128real:
735 ftcb.emit_tai(tai_realconst.create_s128real(value),def);
736 else
737 internalerror(200611053);
738 end;
739 end;
740
741
742 procedure tasmlisttypedconstbuilder.tc_emit_classrefdef(def: tclassrefdef; var node: tnode);
743 begin
744 case node.nodetype of
745 loadvmtaddrn:
746 begin
747 if not def_is_related(tobjectdef(tclassrefdef(node.resultdef).pointeddef),tobjectdef(def.pointeddef)) then
748 IncompatibleTypes(node.resultdef, def);
749 ftcb.emit_tai(Tai_const.Create_sym(current_asmdata.RefAsmSymbol(Tobjectdef(tclassrefdef(node.resultdef).pointeddef).vmt_mangledname,AT_DATA)),def);
750 end;
751 niln:
752 ftcb.emit_tai(Tai_const.Create_sym(nil),def);
753 else if is_constnode(node) then
754 IncompatibleTypes(node.resultdef, def)
755 else
756 Message(parser_e_illegal_expression);
757 end;
758 end;
759
760
761 procedure tasmlisttypedconstbuilder.tc_emit_pointerdef(def: tpointerdef; var node: tnode);
762 var
763 hp : tnode;
764 srsym : tsym;
765 pd : tprocdef;
766 ca : pchar;
767 pw : pcompilerwidestring;
768 i,len : longint;
769 ll : tasmlabel;
770 varalign : shortint;
771 datadef : tdef;
772 datatcb : ttai_typedconstbuilder;
773 begin
774 { remove equal typecasts for pointer/nil addresses }
775 if (node.nodetype=typeconvn) then
776 with Ttypeconvnode(node) do
777 if (left.nodetype in [addrn,niln]) and equal_defs(def,node.resultdef) then
778 begin
779 hp:=left;
780 left:=nil;
781 node.free;
782 node:=hp;
783 end;
784 { allows horrible ofs(typeof(TButton)^) code !! }
785 if (node.nodetype=typeconvn) then
786 with Ttypeconvnode(node) do
787 if (left.nodetype=addrn) and equal_defs(uinttype,node.resultdef) then
788 begin
789 hp:=left;
790 left:=nil;
791 node.free;
792 node:=hp;
793 end;
794 if (node.nodetype=addrn) then
795 with Taddrnode(node) do
796 if left.nodetype=derefn then
797 begin
798 hp:=tderefnode(left).left;
799 tderefnode(left).left:=nil;
800 node.free;
801 node:=hp;
802 end;
803 { const pointer ? }
804 if (node.nodetype = pointerconstn) then
805 begin
806 ftcb.queue_init(def);
807 ftcb.queue_typeconvn(ptrsinttype,def);
808 {$if sizeof(TConstPtrUInt)=8}
809 ftcb.queue_emit_ordconst(int64(tpointerconstnode(node).value),ptrsinttype);
810 {$else}
811 {$if sizeof(TConstPtrUInt)=4}
812 ftcb.queue_emit_ordconst(longint(tpointerconstnode(node).value),ptrsinttype);
813 {$else}
814 {$if sizeof(TConstPtrUInt)=2}
815 ftcb.queue_emit_ordconst(smallint(tpointerconstnode(node).value),ptrsinttype);
816 {$else}
817 {$if sizeof(TConstPtrUInt)=1}
818 ftcb.queue_emit_ordconst(shortint(tpointerconstnode(node).value),ptrsinttype);
819 {$else}
820 internalerror(200404122);
821 {$endif} {$endif} {$endif} {$endif}
822 end
823 { nil pointer ? }
824 else if node.nodetype=niln then
825 ftcb.emit_tai(Tai_const.Create_sym(nil),def)
826 { maybe pchar ? }
827 else
828 if is_char(def.pointeddef) and
829 (node.nodetype<>addrn) then
830 begin
831 { create a tcb for the string data (it's placed in a separate
832 asmlist) }
833 ftcb.start_internal_data_builder(fdatalist,sec_rodata_norel,'',datatcb,ll);
834 if node.nodetype=stringconstn then
835 varalign:=size_2_align(tstringconstnode(node).len)
836 else
837 varalign:=1;
838 varalign:=const_align(varalign);
839 { represent the string data as an array }
840 if node.nodetype=stringconstn then
841 begin
842 len:=tstringconstnode(node).len;
843 { For tp7 the maximum lentgh can be 255 }
844 if (m_tp7 in current_settings.modeswitches) and
845 (len>255) then
846 len:=255;
847 getmem(ca,len+1);
848 move(tstringconstnode(node).value_str^,ca^,len+1);
849 datadef:=carraydef.getreusable(cansichartype,len+1);
850 datatcb.maybe_begin_aggregate(datadef);
851 datatcb.emit_tai(Tai_string.Create_pchar(ca,len+1),datadef);
852 datatcb.maybe_end_aggregate(datadef);
853 end
854 else if is_constcharnode(node) then
855 begin
856 datadef:=carraydef.getreusable(cansichartype,2);
857 datatcb.maybe_begin_aggregate(datadef);
858 datatcb.emit_tai(Tai_string.Create(char(byte(tordconstnode(node).value.svalue))+#0),datadef);
859 datatcb.maybe_end_aggregate(datadef);
860 end
861 else
862 begin
863 IncompatibleTypes(node.resultdef, def);
864 datadef:=carraydef.getreusable(cansichartype,1);
865 end;
866 ftcb.finish_internal_data_builder(datatcb,ll,datadef,varalign);
867 { we now emit the address of the first element of the array
868 containing the string data }
869 ftcb.queue_init(def);
870 { the first element ... }
871 ftcb.queue_vecn(datadef,0);
872 { ... of the string array }
873 ftcb.queue_emit_asmsym(ll,datadef);
874 end
875 { maybe pwidechar ? }
876 else
877 if is_widechar(def.pointeddef) and
878 (node.nodetype<>addrn) then
879 begin
880 if (node.nodetype in [stringconstn,ordconstn]) then
881 begin
882 { convert to unicodestring stringconstn }
883 inserttypeconv(node,cunicodestringtype);
884 if (node.nodetype=stringconstn) and
885 (tstringconstnode(node).cst_type in [cst_widestring,cst_unicodestring]) then
886 begin
887 { create a tcb for the string data (it's placed in a separate
888 asmlist) }
889 ftcb.start_internal_data_builder(fdatalist,sec_rodata,'',datatcb,ll);
890 datatcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable,tcalo_apply_constalign]);
891 pw:=pcompilerwidestring(tstringconstnode(node).value_str);
892 { include terminating #0 }
893 datadef:=carraydef.getreusable(cwidechartype,tstringconstnode(node).len+1);
894 datatcb.maybe_begin_aggregate(datadef);
895 for i:=0 to tstringconstnode(node).len-1 do
896 datatcb.emit_tai(Tai_const.Create_16bit(pw^.data[i]),cwidechartype);
897 { ending #0 }
898 datatcb.emit_tai(Tai_const.Create_16bit(0),cwidechartype);
899 datatcb.maybe_end_aggregate(datadef);
900 { concat add the string data to the fdatalist }
901 ftcb.finish_internal_data_builder(datatcb,ll,datadef,const_align(sizeof(pint)));
902 { we now emit the address of the first element of the array
903 containing the string data }
904 ftcb.queue_init(def);
905 { the first element ... }
906 ftcb.queue_vecn(datadef,0);
907 { ... of the string array }
908 ftcb.queue_emit_asmsym(ll,datadef);
909 end;
910 end
911 else
912 IncompatibleTypes(node.resultdef, def);
913 end
914 else
915 if (node.nodetype=addrn) or
916 is_proc2procvar_load(node,pd) then
917 begin
918 { insert typeconv }
919 inserttypeconv(node,def);
920 hp:=node;
921 while assigned(hp) and (hp.nodetype in [addrn,typeconvn,subscriptn,vecn]) do
922 hp:=tunarynode(hp).left;
923 if (hp.nodetype=loadn) then
924 begin
925 hp:=node;
926 ftcb.queue_init(def);
927 while assigned(hp) and (hp.nodetype<>loadn) do
928 begin
929 case hp.nodetype of
930 vecn :
931 begin
932 if (is_constintnode(tvecnode(hp).right) or
933 is_constenumnode(tvecnode(hp).right) or
934 is_constcharnode(tvecnode(hp).right) or
935 is_constboolnode(tvecnode(hp).right)) and
936 not is_implicit_array_pointer(tvecnode(hp).left.resultdef) then
937 ftcb.queue_vecn(tvecnode(hp).left.resultdef,get_ordinal_value(tvecnode(hp).right))
938 else
939 Message(parser_e_illegal_expression);
940 end;
941 subscriptn :
942 ftcb.queue_subscriptn(tabstractrecorddef(tsubscriptnode(hp).left.resultdef),tsubscriptnode(hp).vs);
943 typeconvn :
944 begin
945 if not(ttypeconvnode(hp).convtype in [tc_equal,tc_proc_2_procvar]) then
946 Message(parser_e_illegal_expression)
947 else
948 ftcb.queue_typeconvn(ttypeconvnode(hp).left.resultdef,hp.resultdef);
949 end;
950 addrn :
951 { nothing, is implicit };
952 else
953 Message(parser_e_illegal_expression);
954 end;
955 hp:=tunarynode(hp).left;
956 end;
957 srsym:=tloadnode(hp).symtableentry;
958 case srsym.typ of
959 procsym :
960 begin
961 pd:=tprocdef(tprocsym(srsym).ProcdefList[0]);
962 if Tprocsym(srsym).ProcdefList.Count>1 then
963 Message(parser_e_no_overloaded_procvars);
964 if po_abstractmethod in pd.procoptions then
965 Message(type_e_cant_take_address_of_abstract_method)
966 else
967 ftcb.queue_emit_proc(pd);
968 end;
969 staticvarsym :
970 ftcb.queue_emit_staticvar(tstaticvarsym(srsym));
971 labelsym :
972 ftcb.queue_emit_label(tlabelsym(srsym));
973 constsym :
974 if tconstsym(srsym).consttyp=constresourcestring then
975 ftcb.queue_emit_const(tconstsym(srsym))
976 else
977 Message(type_e_variable_id_expected);
978 else
979 Message(type_e_variable_id_expected);
980 end;
981 end
982 else
983 Message(parser_e_illegal_expression);
984 end
985 else
986 { allow typeof(Object type)}
987 if (node.nodetype=inlinen) and
988 (tinlinenode(node).inlinenumber=in_typeof_x) then
989 begin
990 if (tinlinenode(node).left.nodetype=typen) then
991 begin
992 // TODO correct type?
993 ftcb.emit_tai(Tai_const.createname(
994 tobjectdef(tinlinenode(node).left.resultdef).vmt_mangledname,AT_DATA,0),
995 voidpointertype);
996 end
997 else
998 Message(parser_e_illegal_expression);
999 end
1000 else
1001 Message(parser_e_illegal_expression);
1002 end;
1003
1004
1005 procedure tasmlisttypedconstbuilder.tc_emit_setdef(def: tsetdef; var node: tnode);
1006 type
1007 setbytes = array[0..31] of byte;
1008 Psetbytes = ^setbytes;
1009 var
1010 i: longint;
1011 setval: cardinal;
1012 begin
1013 if node.nodetype=setconstn then
1014 begin
1015 { be sure to convert to the correct result, else
1016 it can generate smallset data instead of normalset (PFV) }
1017 inserttypeconv(node,def);
1018 { we only allow const sets }
1019 if (node.nodetype<>setconstn) or
1020 assigned(tsetconstnode(node).left) then
1021 Message(parser_e_illegal_expression)
1022 else
1023 begin
1024 ftcb.maybe_begin_aggregate(def);
1025 tsetconstnode(node).adjustforsetbase;
1026 { this writing is endian-dependant }
1027 if not is_smallset(def) then
1028 begin
1029 if source_info.endian=target_info.endian then
1030 begin
1031 for i:=0 to node.resultdef.size-1 do
1032 ftcb.emit_tai(tai_const.create_8bit(Psetbytes(tsetconstnode(node).value_set)^[i]),u8inttype);
1033 end
1034 else
1035 begin
1036 for i:=0 to node.resultdef.size-1 do
1037 ftcb.emit_tai(tai_const.create_8bit(reverse_byte(Psetbytes(tsetconstnode(node).value_set)^[i])),u8inttype);
1038 end;
1039 end
1040 else
1041 begin
1042 { emit the set as a single constant (would be nicer if we
1043 could automatically merge the bytes inside the
1044 typed const builder, but it's not easy :/ ) }
1045 setval:=0;
1046 if source_info.endian=target_info.endian then
1047 begin
1048 for i:=0 to node.resultdef.size-1 do
1049 setval:=setval or (Psetbytes(tsetconstnode(node).value_set)^[i] shl (i*8));
1050 end
1051 else
1052 begin
1053 for i:=0 to node.resultdef.size-1 do
1054 setval:=setval or (reverse_byte(Psetbytes(tsetconstnode(node).value_set)^[i]) shl (i*8));
1055 end;
1056 case def.size of
1057 1:
1058 ftcb.emit_tai(tai_const.create_8bit(setval),def);
1059 2:
1060 begin
1061 if target_info.endian=endian_big then
1062 setval:=swapendian(word(setval));
1063 ftcb.emit_tai(tai_const.create_16bit(setval),def);
1064 end;
1065 4:
1066 begin
1067 if target_info.endian=endian_big then
1068 setval:=swapendian(cardinal(setval));
1069 ftcb.emit_tai(tai_const.create_32bit(longint(setval)),def);
1070 end;
1071 else
1072 internalerror(2015112207);
1073 end;
1074 end;
1075 ftcb.maybe_end_aggregate(def);
1076 end;
1077 end
1078 else
1079 Message(parser_e_illegal_expression);
1080 end;
1081
1082
1083 procedure tasmlisttypedconstbuilder.tc_emit_enumdef(def: tenumdef; var node: tnode);
1084 begin
1085 if node.nodetype=ordconstn then
1086 begin
1087 if equal_defs(node.resultdef,def) or
1088 is_subequal(node.resultdef,def) then
1089 begin
1090 adaptrange(def,tordconstnode(node).value,false,false,cs_check_range in current_settings.localswitches);
1091 case longint(node.resultdef.size) of
1092 1 : ftcb.emit_tai(Tai_const.Create_8bit(Byte(tordconstnode(node).value.svalue)),def);
1093 2 : ftcb.emit_tai(Tai_const.Create_16bit(Word(tordconstnode(node).value.svalue)),def);
1094 4 : ftcb.emit_tai(Tai_const.Create_32bit(Longint(tordconstnode(node).value.svalue)),def);
1095 end;
1096 end
1097 else
1098 IncompatibleTypes(node.resultdef,def);
1099 end
1100 else
1101 Message(parser_e_illegal_expression);
1102 end;
1103
1104
1105 { parse a single constant and add it to the packed const info }
1106 { represented by curval etc (see explanation of bitpackval for }
1107 { what the different parameters mean) }
tasmlisttypedconstbuilder.parse_single_packed_constnull1108 function tasmlisttypedconstbuilder.parse_single_packed_const(def: tdef; var bp: tbitpackedval): boolean;
1109 var
1110 node: tnode;
1111 begin
1112 result:=true;
1113 node:=comp_expr([ef_accept_equal]);
1114 if (node.nodetype <> ordconstn) or
1115 (not equal_defs(node.resultdef,def) and
1116 not is_subequal(node.resultdef,def)) then
1117 begin
1118 incompatibletypes(node.resultdef,def);
1119 node.free;
1120 consume_all_until(_SEMICOLON);
1121 result:=false;
1122 exit;
1123 end;
1124 if (Tordconstnode(node).value<qword(low(Aword))) or (Tordconstnode(node).value>qword(high(Aword))) then
1125 message3(type_e_range_check_error_bounds,tostr(Tordconstnode(node).value),tostr(low(Aword)),tostr(high(Aword)))
1126 else
1127 bitpackval(Tordconstnode(node).value.uvalue,bp);
1128 if (bp.curbitoffset>=AIntBits) then
1129 flush_packed_value(bp);
1130 node.free;
1131 end;
1132
1133 procedure tasmlisttypedconstbuilder.get_final_asmlists(out reslist, datalist: tasmlist);
1134 var
1135 asmsym: tasmsymbol;
1136 addstabx: boolean;
1137 sec: TAsmSectiontype;
1138 secname: ansistring;
1139 begin
1140 addstabx:=false;
1141 if fsym.globalasmsym then
1142 begin
1143 if (target_dbg.id=dbg_stabx) and
1144 (cs_debuginfo in current_settings.moduleswitches) and
1145 not assigned(current_asmdata.GetAsmSymbol(fsym.name)) then
1146 addstabx:=true;
1147 asmsym:=current_asmdata.DefineAsmSymbol(fsym.mangledname,AB_GLOBAL,AT_DATA,tcsym.vardef)
1148 end
1149 else
1150 asmsym:=current_asmdata.DefineAsmSymbol(fsym.mangledname,AB_LOCAL,AT_DATA,tcsym.vardef);
1151 if vo_has_section in fsym.varoptions then
1152 begin
1153 sec:=sec_user;
1154 secname:=fsym.section;
1155 end
1156 else
1157 begin
1158 { Certain types like windows WideString are initialized at runtime and cannot
1159 be placed into readonly memory }
1160 if (fsym.varspez=vs_const) and
1161 not (vo_force_finalize in fsym.varoptions) then
1162 sec:=sec_rodata
1163 else
1164 sec:=sec_data;
1165 secname:=asmsym.Name;
1166 end;
1167 reslist:=ftcb.get_final_asmlist(asmsym,fsym.vardef,sec,secname,fsym.vardef.alignment);
1168 if addstabx then
1169 begin
1170 { see same code in ncgutil.insertbssdata }
1171 reslist.insert(tai_directive.Create(asd_reference,fsym.name));
1172 reslist.insert(tai_symbol.Create(current_asmdata.DefineAsmSymbol(fsym.name,AB_LOCAL,AT_DATA,tcsym.vardef),0));
1173 end;
1174 datalist:=fdatalist;
1175 end;
1176
1177
1178 procedure tasmlisttypedconstbuilder.parse_arraydef(def:tarraydef);
1179 const
1180 LKlammerToken: array[Boolean] of TToken = (_LKLAMMER, _LECKKLAMMER);
1181 RKlammerToken: array[Boolean] of TToken = (_RKLAMMER, _RECKKLAMMER);
1182 var
1183 n : tnode;
1184 i : longint;
1185 len : asizeint;
1186 ch : array[0..1] of char;
1187 ca : pbyte;
1188 int_const: tai_const;
1189 char_size: integer;
1190 dyncount,
1191 oldoffset: asizeint;
1192 dummy : byte;
1193 sectype : tasmsectiontype;
1194 oldtcb,
1195 datatcb : ttai_typedconstbuilder;
1196 ll : tasmlabel;
1197 dyncountloc : ttypedconstplaceholder;
1198 llofs : tasmlabofs;
1199 dynarrdef : tdef;
1200 begin
1201 { dynamic array }
1202 if is_dynamic_array(def) then
1203 begin
1204 if try_to_consume(_NIL) then
1205 begin
1206 ftcb.emit_tai(Tai_const.Create_sym(nil),def);
1207 end
1208 else if try_to_consume(LKlammerToken[m_delphi in current_settings.modeswitches]) then
1209 begin
1210 if try_to_consume(RKlammerToken[m_delphi in current_settings.modeswitches]) then
1211 begin
1212 ftcb.emit_tai(tai_const.create_sym(nil),def);
1213 end
1214 else
1215 begin
1216 if fsym.varspez=vs_const then
1217 sectype:=sec_rodata
1218 else
1219 sectype:=sec_data;
1220 ftcb.start_internal_data_builder(fdatalist,sectype,'',datatcb,ll);
1221
1222 llofs:=datatcb.begin_dynarray_const(def,ll,dyncountloc);
1223
1224 dyncount:=0;
1225
1226 oldtcb:=ftcb;
1227 ftcb:=datatcb;
1228 while true do
1229 begin
1230 read_typed_const_data(def.elementdef);
1231 inc(dyncount);
1232 if try_to_consume(RKlammerToken[m_delphi in current_settings.modeswitches]) then
1233 break
1234 else
1235 consume(_COMMA);
1236 end;
1237 ftcb:=oldtcb;
1238
1239 dynarrdef:=datatcb.end_dynarray_const(def,dyncount,dyncountloc);
1240
1241 ftcb.finish_internal_data_builder(datatcb,ll,dynarrdef,sizeof(pint));
1242
1243 ftcb.emit_dynarray_offset(llofs,dyncount,def);
1244 end;
1245 end
1246 else
1247 consume(_LKLAMMER);
1248 end
1249 { packed array constant }
1250 else if is_packed_array(def) and
1251 ((def.elepackedbitsize mod 8 <> 0) or
1252 not ispowerof2(def.elepackedbitsize div 8,i)) then
1253 begin
1254 parse_packed_array_def(def);
1255 end
1256 { normal array const between brackets }
1257 else if try_to_consume(_LKLAMMER) then
1258 begin
1259 ftcb.maybe_begin_aggregate(def);
1260 oldoffset:=curoffset;
1261 curoffset:=0;
1262 { in case of a generic subroutine, it might be we cannot
1263 determine the size yet }
1264 if assigned(current_procinfo) and (df_generic in current_procinfo.procdef.defoptions) then
1265 begin
1266 while true do
1267 begin
1268 read_typed_const_data(def.elementdef);
1269 if token=_RKLAMMER then
1270 begin
1271 consume(_RKLAMMER);
1272 break;
1273 end
1274 else
1275 consume(_COMMA);
1276 end;
1277 end
1278 else
1279 begin
1280 for i:=def.lowrange to def.highrange-1 do
1281 begin
1282 read_typed_const_data(def.elementdef);
1283 Inc(curoffset,def.elementdef.size);
1284 if token=_RKLAMMER then
1285 begin
1286 Message1(parser_e_more_array_elements_expected,tostr(def.highrange-i));
1287 consume(_RKLAMMER);
1288 exit;
1289 end
1290 else
1291 consume(_COMMA);
1292 end;
1293 read_typed_const_data(def.elementdef);
1294 consume(_RKLAMMER);
1295 end;
1296 curoffset:=oldoffset;
1297 ftcb.maybe_end_aggregate(def);
1298 end
1299 { if array of char then we allow also a string }
1300 else if is_anychar(def.elementdef) then
1301 begin
1302 ftcb.maybe_begin_aggregate(def);
1303 char_size:=def.elementdef.size;
1304 n:=comp_expr([ef_accept_equal]);
1305 if n.nodetype=stringconstn then
1306 begin
1307 len:=tstringconstnode(n).len;
1308 case char_size of
1309 1:
1310 begin
1311 if (tstringconstnode(n).cst_type in [cst_unicodestring,cst_widestring]) then
1312 inserttypeconv(n,getansistringdef);
1313 if n.nodetype<>stringconstn then
1314 internalerror(2010033003);
1315 ca:=pointer(tstringconstnode(n).value_str);
1316 end;
1317 2:
1318 begin
1319 inserttypeconv(n,cunicodestringtype);
1320 if n.nodetype<>stringconstn then
1321 internalerror(2010033003);
1322 ca:=pointer(pcompilerwidestring(tstringconstnode(n).value_str)^.data)
1323 end;
1324 else
1325 internalerror(2010033005);
1326 end;
1327 { For tp7 the maximum lentgh can be 255 }
1328 if (m_tp7 in current_settings.modeswitches) and
1329 (len>255) then
1330 len:=255;
1331 end
1332 else if is_constcharnode(n) then
1333 begin
1334 case char_size of
1335 1:
1336 ch[0]:=chr(tordconstnode(n).value.uvalue and $ff);
1337 2:
1338 begin
1339 inserttypeconv(n,cwidechartype);
1340 if not is_constwidecharnode(n) then
1341 internalerror(2010033001);
1342 widechar(ch):=widechar(tordconstnode(n).value.uvalue and $ffff);
1343 end;
1344 else
1345 internalerror(2010033002);
1346 end;
1347 ca:=@ch;
1348 len:=1;
1349 end
1350 else if is_constwidecharnode(n) and (current_settings.sourcecodepage<>CP_UTF8) then
1351 begin
1352 case char_size of
1353 1:
1354 begin
1355 inserttypeconv(n,cansichartype);
1356 if not is_constcharnode(n) then
1357 internalerror(2010033001);
1358 ch[0]:=chr(tordconstnode(n).value.uvalue and $ff);
1359 end;
1360 2:
1361 widechar(ch):=widechar(tordconstnode(n).value.uvalue and $ffff);
1362 else
1363 internalerror(2010033002);
1364 end;
1365 ca:=@ch;
1366 len:=1;
1367 end
1368 else
1369 begin
1370 Message(parser_e_illegal_expression);
1371 len:=0;
1372 { avoid crash later on }
1373 dummy:=0;
1374 ca:=@dummy;
1375 end;
1376 if len>(def.highrange-def.lowrange+1) then
1377 Message(parser_e_string_larger_array);
1378 for i:=0 to def.highrange-def.lowrange do
1379 begin
1380 if i<len then
1381 begin
1382 case char_size of
1383 1:
1384 int_const:=Tai_const.Create_char(char_size,pbyte(ca)^);
1385 2:
1386 int_const:=Tai_const.Create_char(char_size,pword(ca)^);
1387 else
1388 internalerror(2010033004);
1389 end;
1390 inc(ca, char_size);
1391 end
1392 else
1393 {Fill the remaining positions with #0.}
1394 int_const:=Tai_const.Create_char(char_size,0);
1395 ftcb.emit_tai(int_const,def.elementdef)
1396 end;
1397 ftcb.maybe_end_aggregate(def);
1398 n.free;
1399 end
1400 else
1401 begin
1402 { we want the ( }
1403 consume(_LKLAMMER);
1404 end;
1405 end;
1406
1407
1408 procedure tasmlisttypedconstbuilder.parse_procvardef(def:tprocvardef);
1409 var
1410 tmpn,n : tnode;
1411 pd : tprocdef;
1412 procaddrdef: tprocvardef;
1413 havepd,
1414 haveblock: boolean;
1415 begin
1416 { Procvars and pointers are no longer compatible. }
1417 { under tp: =nil or =var under fpc: =nil or =@var }
1418 if try_to_consume(_NIL) then
1419 begin
1420 ftcb.maybe_begin_aggregate(def);
1421 { we need the procdef type called by the procvar here, not the
1422 procvar record }
1423 ftcb.emit_tai_procvar2procdef(Tai_const.Create_sym(nil),def);
1424 if not def.is_addressonly then
1425 ftcb.emit_tai(Tai_const.Create_sym(nil),voidpointertype);
1426 ftcb.maybe_end_aggregate(def);
1427 exit;
1428 end;
1429 { you can't assign a value other than NIL to a typed constant }
1430 { which is a "procedure of object", because this also requires }
1431 { address of an object/class instance, which is not known at }
1432 { compile time (JM) }
1433 if (po_methodpointer in def.procoptions) then
1434 Message(parser_e_no_procvarobj_const);
1435 { parse the rest too, so we can continue with error checking }
1436 getprocvardef:=def;
1437 n:=comp_expr([ef_accept_equal]);
1438 getprocvardef:=nil;
1439 if codegenerror then
1440 begin
1441 n.free;
1442 exit;
1443 end;
1444 { let type conversion check everything needed }
1445 inserttypeconv(n,def);
1446 if codegenerror then
1447 begin
1448 n.free;
1449 exit;
1450 end;
1451 { in case of a nested procdef initialised with a global routine }
1452 ftcb.maybe_begin_aggregate(def);
1453 { get the address of the procedure, except if it's a C-block (then we
1454 we will end up with a record that represents the C-block) }
1455 if not is_block(def) then
1456 procaddrdef:=cprocvardef.getreusableprocaddr(def)
1457 else
1458 procaddrdef:=def;
1459 ftcb.queue_init(procaddrdef);
1460 { remove typeconvs, that will normally insert a lea
1461 instruction which is not necessary for us }
1462 while n.nodetype=typeconvn do
1463 begin
1464 ftcb.queue_typeconvn(ttypeconvnode(n).left.resultdef,n.resultdef);
1465 tmpn:=ttypeconvnode(n).left;
1466 ttypeconvnode(n).left:=nil;
1467 n.free;
1468 n:=tmpn;
1469 end;
1470 { remove addrn which we also don't need here }
1471 if n.nodetype=addrn then
1472 begin
1473 tmpn:=taddrnode(n).left;
1474 taddrnode(n).left:=nil;
1475 n.free;
1476 n:=tmpn;
1477 end;
1478 pd:=nil;
1479 { we now need to have a loadn with a procsym }
1480 havepd:=
1481 (n.nodetype=loadn) and
1482 (tloadnode(n).symtableentry.typ=procsym);
1483 { or a staticvarsym representing a block }
1484 haveblock:=
1485 (n.nodetype=loadn) and
1486 (tloadnode(n).symtableentry.typ=staticvarsym) and
1487 (sp_internal in tloadnode(n).symtableentry.symoptions);
1488 if havepd or
1489 haveblock then
1490 begin
1491 if havepd then
1492 begin
1493 pd:=tloadnode(n).procdef;
1494 ftcb.queue_emit_proc(pd);
1495 end
1496 else
1497 begin
1498 ftcb.queue_emit_staticvar(tstaticvarsym(tloadnode(n).symtableentry));
1499 end;
1500 { nested procvar typed consts can only be initialised with nil
1501 (checked above) or with a global procedure (checked here),
1502 because in other cases we need a valid frame pointer }
1503 if is_nested_pd(def) then
1504 begin
1505 if haveblock or
1506 is_nested_pd(pd) then
1507 Message(parser_e_no_procvarnested_const);
1508 ftcb.emit_tai(Tai_const.Create_sym(nil),voidpointertype);
1509 end;
1510 end
1511 else if n.nodetype=pointerconstn then
1512 begin
1513 ftcb.queue_emit_ordconst(tpointerconstnode(n).value,procaddrdef);
1514 if not def.is_addressonly then
1515 ftcb.emit_tai(Tai_const.Create_sym(nil),voidpointertype);
1516 end
1517 else
1518 Message(parser_e_illegal_expression);
1519 ftcb.maybe_end_aggregate(def);
1520 n.free;
1521 end;
1522
1523
1524 procedure tasmlisttypedconstbuilder.parse_recorddef(def:trecorddef);
1525 var
1526 n : tnode;
1527 symidx : longint;
1528 recsym,
1529 srsym : tsym;
1530 hs : string;
1531 sorg,s : TIDString;
1532 tmpguid : tguid;
1533 recoffset,
1534 fillbytes : {$ifdef CPU8BITALU}smallint{$else}aint{$endif};
1535 bp : tbitpackedval;
1536 error,
1537 is_packed: boolean;
1538 startoffset: {$ifdef CPU8BITALU}word{$else}aword{$endif};
1539
1540 procedure handle_stringconstn;
1541 begin
1542 hs:=strpas(tstringconstnode(n).value_str);
1543 if string2guid(hs,tmpguid) then
1544 ftcb.emit_guid_const(tmpguid)
1545 else
1546 Message(parser_e_improper_guid_syntax);
1547 end;
1548
1549 var
1550 i : longint;
1551 SymList:TFPHashObjectList;
1552 begin
1553 { GUID }
1554 if (def=rec_tguid) and (token=_ID) then
1555 begin
1556 n:=comp_expr([ef_accept_equal]);
1557 if n.nodetype=stringconstn then
1558 handle_stringconstn
1559 else
1560 begin
1561 inserttypeconv(n,rec_tguid);
1562 if n.nodetype=guidconstn then
1563 ftcb.emit_guid_const(tguidconstnode(n).value)
1564 else
1565 Message(parser_e_illegal_expression);
1566 end;
1567 n.free;
1568 exit;
1569 end;
1570 if (def=rec_tguid) and ((token=_CSTRING) or (token=_CCHAR)) then
1571 begin
1572 n:=comp_expr([ef_accept_equal]);
1573 inserttypeconv(n,cshortstringtype);
1574 if n.nodetype=stringconstn then
1575 handle_stringconstn
1576 else
1577 Message(parser_e_illegal_expression);
1578 n.free;
1579 exit;
1580 end;
1581 ftcb.maybe_begin_aggregate(def);
1582 { bitpacked record? }
1583 is_packed:=is_packed_record_or_object(def);
1584 if (is_packed) then
1585 { packedbitsize will be set separately for each field }
1586 initbitpackval(bp,0);
1587 { normal record }
1588 consume(_LKLAMMER);
1589 recoffset:=0;
1590 sorg:='';
1591 symidx:=0;
1592 symlist:=def.symtable.SymList;
1593 srsym:=get_next_varsym(def,symlist,symidx);
1594 recsym := nil;
1595 startoffset:=curoffset;
1596 while token<>_RKLAMMER do
1597 begin
1598 s:=pattern;
1599 sorg:=orgpattern;
1600 consume(_ID);
1601 consume(_COLON);
1602 error := false;
1603 recsym := tsym(def.symtable.Find(s));
1604 if not assigned(recsym) then
1605 begin
1606 Message1(sym_e_illegal_field,sorg);
1607 error := true;
1608 end;
1609 if (not error) and
1610 (not assigned(srsym) or
1611 (s <> srsym.name)) then
1612 { possible variant record (JM) }
1613 begin
1614 { All parts of a variant start at the same offset }
1615 { Also allow jumping from one variant part to another, }
1616 { as long as the offsets match }
1617 if (assigned(srsym) and
1618 (tfieldvarsym(recsym).fieldoffset = tfieldvarsym(srsym).fieldoffset)) or
1619 { srsym is not assigned after parsing w2 in the }
1620 { typed const in the next example: }
1621 { type tr = record case byte of }
1622 { 1: (l1,l2: dword); }
1623 { 2: (w1,w2: word); }
1624 { end; }
1625 { const r: tr = (w1:1;w2:1;l2:5); }
1626 (tfieldvarsym(recsym).fieldoffset = recoffset) then
1627 begin
1628 srsym:=recsym;
1629 { symidx should contain the next symbol id to search }
1630 symidx:=SymList.indexof(srsym)+1;
1631 end
1632 { going backwards isn't allowed in any mode }
1633 else if (tfieldvarsym(recsym).fieldoffset<recoffset) then
1634 begin
1635 Message(parser_e_invalid_record_const);
1636 error := true;
1637 end
1638 { Delphi allows you to skip fields }
1639 else if (m_delphi in current_settings.modeswitches) then
1640 begin
1641 Message1(parser_w_skipped_fields_before,sorg);
1642 srsym := recsym;
1643 end
1644 { FPC and TP don't }
1645 else
1646 begin
1647 Message1(parser_e_skipped_fields_before,sorg);
1648 error := true;
1649 end;
1650 end;
1651 if error then
1652 consume_all_until(_SEMICOLON)
1653 else
1654 begin
1655 { if needed fill (alignment) }
1656 if tfieldvarsym(srsym).fieldoffset>recoffset then
1657 begin
1658 if not(is_packed) then
1659 fillbytes:=0
1660 else
1661 begin
1662 flush_packed_value(bp);
1663 { curoffset is now aligned to the next byte }
1664 recoffset:=align(recoffset,8);
1665 { offsets are in bits in this case }
1666 fillbytes:=(tfieldvarsym(srsym).fieldoffset-recoffset) div 8;
1667 end;
1668 for i:=1 to fillbytes do
1669 ftcb.emit_tai(Tai_const.Create_8bit(0),u8inttype)
1670 end;
1671
1672 { new position }
1673 recoffset:=tfieldvarsym(srsym).fieldoffset;
1674 if not(is_packed) then
1675 inc(recoffset,tfieldvarsym(srsym).vardef.size)
1676 else
1677 inc(recoffset,tfieldvarsym(srsym).vardef.packedbitsize);
1678
1679 { read the data }
1680 ftcb.next_field:=tfieldvarsym(srsym);
1681 if not(is_packed) or
1682 { only orddefs and enumdefs are bitpacked, as in gcc/gpc }
1683 not(tfieldvarsym(srsym).vardef.typ in [orddef,enumdef]) then
1684 begin
1685 if is_packed then
1686 begin
1687 flush_packed_value(bp);
1688 recoffset:=align(recoffset,8);
1689 end;
1690 curoffset:=startoffset+tfieldvarsym(srsym).fieldoffset;
1691 read_typed_const_data(tfieldvarsym(srsym).vardef);
1692 end
1693 else
1694 begin
1695 bp.packedbitsize:=tfieldvarsym(srsym).vardef.packedbitsize;
1696 parse_single_packed_const(tfieldvarsym(srsym).vardef,bp);
1697 end;
1698
1699 { keep previous field for checking whether whole }
1700 { record was initialized (JM) }
1701 recsym := srsym;
1702 { goto next field }
1703 srsym:=get_next_varsym(def,SymList,symidx);
1704
1705 if token=_SEMICOLON then
1706 consume(_SEMICOLON)
1707 else if (token=_COMMA) and (m_mac in current_settings.modeswitches) then
1708 consume(_COMMA)
1709 else
1710 break;
1711 end;
1712 end;
1713 curoffset:=startoffset;
1714
1715 { are there any fields left, but don't complain if there only
1716 come other variant parts after the last initialized field }
1717 if assigned(srsym) and
1718 (
1719 (recsym=nil) or
1720 (tfieldvarsym(srsym).fieldoffset > tfieldvarsym(recsym).fieldoffset)
1721 ) then
1722 Message1(parser_w_skipped_fields_after,sorg);
1723
1724 if not error then
1725 begin
1726 if not(is_packed) then
1727 fillbytes:=0
1728 else
1729 begin
1730 flush_packed_value(bp);
1731 recoffset:=align(recoffset,8);
1732 fillbytes:=def.size-(recoffset div 8);
1733 end;
1734 for i:=1 to fillbytes do
1735 ftcb.emit_tai(Tai_const.Create_8bit(0),u8inttype);
1736 end;
1737
1738 ftcb.maybe_end_aggregate(def);
1739 consume(_RKLAMMER);
1740 end;
1741
1742
1743 procedure tasmlisttypedconstbuilder.parse_objectdef(def:tobjectdef);
1744 var
1745 n : tnode;
1746 obj : tobjectdef;
1747 srsym : tsym;
1748 st : tsymtable;
1749 objoffset : {$ifdef CPU8BITALU}smallint{$else}aint{$endif};
1750 s,sorg : TIDString;
1751 vmtwritten : boolean;
1752 startoffset : {$ifdef CPU8BITALU}smallint{$else}aint{$endif};
1753 begin
1754 { no support for packed object }
1755 if is_packed_record_or_object(def) then
1756 begin
1757 Message(type_e_no_const_packed_record);
1758 exit;
1759 end;
1760
1761 { only allow nil for implicit pointer object types }
1762 if is_implicit_pointer_object_type(def) then
1763 begin
1764 n:=comp_expr([ef_accept_equal]);
1765 if n.nodetype<>niln then
1766 begin
1767 Message(parser_e_type_const_not_possible);
1768 consume_all_until(_SEMICOLON);
1769 end
1770 else
1771 ftcb.emit_tai(Tai_const.Create_sym(nil),def);
1772 n.free;
1773 exit;
1774 end;
1775
1776 { for objects we allow it only if it doesn't contain a vmt }
1777 if (oo_has_vmt in def.objectoptions) and
1778 (m_fpc in current_settings.modeswitches) then
1779 begin
1780 Message(parser_e_type_object_constants);
1781 exit;
1782 end;
1783
1784 ftcb.maybe_begin_aggregate(def);
1785
1786 consume(_LKLAMMER);
1787 startoffset:=curoffset;
1788 objoffset:=0;
1789 vmtwritten:=false;
1790 while token<>_RKLAMMER do
1791 begin
1792 s:=pattern;
1793 sorg:=orgpattern;
1794 consume(_ID);
1795 consume(_COLON);
1796 srsym:=nil;
1797 obj:=tobjectdef(def);
1798 st:=obj.symtable;
1799 while (srsym=nil) and assigned(st) do
1800 begin
1801 srsym:=tsym(st.Find(s));
1802 if assigned(obj) then
1803 obj:=obj.childof;
1804 if assigned(obj) then
1805 st:=obj.symtable
1806 else
1807 st:=nil;
1808 end;
1809
1810 if (srsym=nil) or
1811 (srsym.typ<>fieldvarsym) then
1812 begin
1813 if (srsym=nil) then
1814 Message1(sym_e_id_not_found,sorg)
1815 else
1816 Message1(sym_e_illegal_field,sorg);
1817 consume_all_until(_RKLAMMER);
1818 break;
1819 end
1820 else
1821 with tfieldvarsym(srsym) do
1822 begin
1823 { check position }
1824 if fieldoffset<objoffset then
1825 message(parser_e_invalid_record_const);
1826
1827 { check in VMT needs to be added for TP mode }
1828 if not(vmtwritten) and
1829 not(m_fpc in current_settings.modeswitches) and
1830 (oo_has_vmt in def.objectoptions) and
1831 (def.vmt_offset<fieldoffset) then
1832 begin
1833 ftcb.next_field:=tfieldvarsym(def.vmt_field);
1834 ftcb.emit_tai(tai_const.createname(def.vmt_mangledname,AT_DATA,0),tfieldvarsym(def.vmt_field).vardef);
1835 objoffset:=def.vmt_offset+tfieldvarsym(def.vmt_field).vardef.size;
1836 vmtwritten:=true;
1837 end;
1838
1839 ftcb.next_field:=tfieldvarsym(srsym);
1840
1841 { new position }
1842 objoffset:=fieldoffset+vardef.size;
1843
1844 { read the data }
1845 curoffset:=startoffset+fieldoffset;
1846 read_typed_const_data(vardef);
1847
1848 if not try_to_consume(_SEMICOLON) then
1849 break;
1850 end;
1851 end;
1852 curoffset:=startoffset;
1853 { add VMT pointer if we stopped writing fields before the VMT was
1854 written }
1855 if not(m_fpc in current_settings.modeswitches) and
1856 (oo_has_vmt in def.objectoptions) and
1857 (def.vmt_offset>=objoffset) then
1858 begin
1859 ftcb.next_field:=tfieldvarsym(def.vmt_field);
1860 ftcb.emit_tai(tai_const.createname(def.vmt_mangledname,AT_DATA,0),tfieldvarsym(def.vmt_field).vardef);
1861 objoffset:=def.vmt_offset+tfieldvarsym(def.vmt_field).vardef.size;
1862 end;
1863 ftcb.maybe_end_aggregate(def);
1864 consume(_RKLAMMER);
1865 end;
1866
1867
1868 procedure tasmlisttypedconstbuilder.parse_into_asmlist;
1869 begin
1870 read_typed_const_data(tcsym.vardef);
1871 end;
1872
1873
1874 { tnodetreetypedconstbuilder }
1875
1876 procedure tnodetreetypedconstbuilder.parse_arraydef(def: tarraydef);
1877 var
1878 n : tnode;
1879 i : longint;
1880 orgbase: tnode;
1881 begin
1882 { dynamic array nil }
1883 if is_dynamic_array(def) then
1884 begin
1885 { Only allow nil initialization }
1886 consume(_NIL);
1887 addstatement(statmnt,cassignmentnode.create_internal(basenode,cnilnode.create));
1888 basenode:=nil;
1889 end
1890 { array const between brackets }
1891 else if try_to_consume(_LKLAMMER) then
1892 begin
1893 orgbase:=basenode;
1894 for i:=def.lowrange to def.highrange-1 do
1895 begin
1896 basenode:=cvecnode.create(orgbase.getcopy,ctypeconvnode.create_explicit(genintconstnode(i),tarraydef(def).rangedef));
1897 read_typed_const_data(def.elementdef);
1898 if token=_RKLAMMER then
1899 begin
1900 Message1(parser_e_more_array_elements_expected,tostr(def.highrange-i));
1901 consume(_RKLAMMER);
1902 exit;
1903 end
1904 else
1905 consume(_COMMA);
1906 end;
1907 basenode:=cvecnode.create(orgbase,ctypeconvnode.create_explicit(genintconstnode(def.highrange),tarraydef(def).rangedef));
1908 read_typed_const_data(def.elementdef);
1909 consume(_RKLAMMER);
1910 end
1911 { if array of char then we allow also a string }
1912 else if is_anychar(def.elementdef) then
1913 begin
1914 n:=comp_expr([ef_accept_equal]);
1915 addstatement(statmnt,cassignmentnode.create_internal(basenode,n));
1916 basenode:=nil;
1917 end
1918 else
1919 begin
1920 { we want the ( }
1921 consume(_LKLAMMER);
1922 end;
1923 end;
1924
1925
1926 procedure tnodetreetypedconstbuilder.parse_procvardef(def: tprocvardef);
1927 begin
1928 addstatement(statmnt,cassignmentnode.create_internal(basenode,comp_expr([ef_accept_equal])));
1929 basenode:=nil;
1930 end;
1931
1932
1933 procedure tnodetreetypedconstbuilder.parse_recorddef(def: trecorddef);
1934 var
1935 n,n2 : tnode;
1936 SymList:TFPHashObjectList;
1937 orgbasenode : tnode;
1938 symidx : longint;
1939 recsym,
1940 srsym : tsym;
1941 sorg,s : TIDString;
1942 recoffset : {$ifdef CPU8BITALU}smallint{$else}aint{$endif};
1943 error,
1944 is_packed: boolean;
1945
1946 procedure handle_stringconstn;
1947 begin
1948 addstatement(statmnt,cassignmentnode.create_internal(basenode,n));
1949 basenode:=nil;
1950 n:=nil;
1951 end;
1952
1953 begin
1954 { GUID }
1955 if (def=rec_tguid) and (token=_ID) then
1956 begin
1957 n:=comp_expr([ef_accept_equal]);
1958 if n.nodetype=stringconstn then
1959 handle_stringconstn
1960 else
1961 begin
1962 inserttypeconv(n,rec_tguid);
1963 if n.nodetype=guidconstn then
1964 begin
1965 n2:=cstringconstnode.createstr(guid2string(tguidconstnode(n).value));
1966 n.free;
1967 n:=n2;
1968 handle_stringconstn;
1969 end
1970 else
1971 Message(parser_e_illegal_expression);
1972 end;
1973 n.free;
1974 exit;
1975 end;
1976 if (def=rec_tguid) and ((token=_CSTRING) or (token=_CCHAR)) then
1977 begin
1978 n:=comp_expr([ef_accept_equal]);
1979 inserttypeconv(n,cshortstringtype);
1980 if n.nodetype=stringconstn then
1981 handle_stringconstn
1982 else
1983 Message(parser_e_illegal_expression);
1984 n.free;
1985 exit;
1986 end;
1987 { bitpacked record? }
1988 is_packed:=is_packed_record_or_object(def);
1989 { normal record }
1990 consume(_LKLAMMER);
1991 recoffset:=0;
1992 sorg:='';
1993 symidx:=0;
1994 symlist:=def.symtable.SymList;
1995 srsym:=get_next_varsym(def,symlist,symidx);
1996 recsym := nil;
1997 orgbasenode:=basenode;
1998 basenode:=nil;
1999 while token<>_RKLAMMER do
2000 begin
2001 s:=pattern;
2002 sorg:=orgpattern;
2003 consume(_ID);
2004 consume(_COLON);
2005 error := false;
2006 recsym := tsym(def.symtable.Find(s));
2007 if not assigned(recsym) then
2008 begin
2009 Message1(sym_e_illegal_field,sorg);
2010 error := true;
2011 end;
2012 if (not error) and
2013 (not assigned(srsym) or
2014 (s <> srsym.name)) then
2015 { possible variant record (JM) }
2016 begin
2017 { All parts of a variant start at the same offset }
2018 { Also allow jumping from one variant part to another, }
2019 { as long as the offsets match }
2020 if (assigned(srsym) and
2021 (tfieldvarsym(recsym).fieldoffset = tfieldvarsym(srsym).fieldoffset)) or
2022 { srsym is not assigned after parsing w2 in the }
2023 { typed const in the next example: }
2024 { type tr = record case byte of }
2025 { 1: (l1,l2: dword); }
2026 { 2: (w1,w2: word); }
2027 { end; }
2028 { const r: tr = (w1:1;w2:1;l2:5); }
2029 (tfieldvarsym(recsym).fieldoffset = recoffset) then
2030 begin
2031 srsym:=recsym;
2032 { symidx should contain the next symbol id to search }
2033 symidx:=SymList.indexof(srsym)+1;
2034 end
2035 { going backwards isn't allowed in any mode }
2036 else if (tfieldvarsym(recsym).fieldoffset<recoffset) then
2037 begin
2038 Message(parser_e_invalid_record_const);
2039 error := true;
2040 end
2041 { Delphi allows you to skip fields }
2042 else if (m_delphi in current_settings.modeswitches) then
2043 begin
2044 Message1(parser_w_skipped_fields_before,sorg);
2045 srsym := recsym;
2046 end
2047 { FPC and TP don't }
2048 else
2049 begin
2050 Message1(parser_e_skipped_fields_before,sorg);
2051 error := true;
2052 end;
2053 end;
2054 if error then
2055 consume_all_until(_SEMICOLON)
2056 else
2057 begin
2058 { skipping fill bytes happens automatically, since we only
2059 initialize the defined fields }
2060 { new position }
2061 recoffset:=tfieldvarsym(srsym).fieldoffset;
2062 if not(is_packed) then
2063 inc(recoffset,tfieldvarsym(srsym).vardef.size)
2064 else
2065 inc(recoffset,tfieldvarsym(srsym).vardef.packedbitsize);
2066
2067 { read the data }
2068 if is_packed and
2069 { only orddefs and enumdefs are bitpacked, as in gcc/gpc }
2070 not(tfieldvarsym(srsym).vardef.typ in [orddef,enumdef]) then
2071 recoffset:=align(recoffset,8);
2072 basenode:=csubscriptnode.create(srsym,orgbasenode.getcopy);
2073 read_typed_const_data(tfieldvarsym(srsym).vardef);
2074
2075 { keep previous field for checking whether whole }
2076 { record was initialized (JM) }
2077 recsym := srsym;
2078 { goto next field }
2079 srsym:=get_next_varsym(def,SymList,symidx);
2080 if token=_SEMICOLON then
2081 consume(_SEMICOLON)
2082 else if (token=_COMMA) and (m_mac in current_settings.modeswitches) then
2083 consume(_COMMA)
2084 else
2085 break;
2086 end;
2087 end;
2088
2089 { are there any fields left, but don't complain if there only
2090 come other variant parts after the last initialized field }
2091 if assigned(srsym) and
2092 (
2093 (recsym=nil) or
2094 (tfieldvarsym(srsym).fieldoffset > tfieldvarsym(recsym).fieldoffset)
2095 ) then
2096 Message1(parser_w_skipped_fields_after,sorg);
2097 orgbasenode.free;
2098 basenode:=nil;
2099
2100 consume(_RKLAMMER);
2101 end;
2102
2103
2104 procedure tnodetreetypedconstbuilder.parse_objectdef(def: tobjectdef);
2105 var
2106 n,
2107 orgbasenode : tnode;
2108 obj : tobjectdef;
2109 srsym : tsym;
2110 st : tsymtable;
2111 objoffset : {$ifdef CPU8BITALU}smallint{$else}aint{$endif};
2112 s,sorg : TIDString;
2113 begin
2114 { no support for packed object }
2115 if is_packed_record_or_object(def) then
2116 begin
2117 Message(type_e_no_const_packed_record);
2118 exit;
2119 end;
2120
2121 { only allow nil for implicit pointer object types }
2122 if is_implicit_pointer_object_type(def) then
2123 begin
2124 n:=comp_expr([ef_accept_equal]);
2125 if n.nodetype<>niln then
2126 begin
2127 Message(parser_e_type_const_not_possible);
2128 consume_all_until(_SEMICOLON);
2129 end
2130 else
2131 begin
2132 addstatement(statmnt,cassignmentnode.create_internal(basenode,n));
2133 n:=nil;
2134 basenode:=nil;
2135 end;
2136 n.free;
2137 exit;
2138 end;
2139
2140 { for objects we allow it only if it doesn't contain a vmt }
2141 if (oo_has_vmt in def.objectoptions) and
2142 (m_fpc in current_settings.modeswitches) then
2143 begin
2144 Message(parser_e_type_object_constants);
2145 exit;
2146 end;
2147
2148 consume(_LKLAMMER);
2149 objoffset:=0;
2150 orgbasenode:=basenode;
2151 basenode:=nil;
2152 while token<>_RKLAMMER do
2153 begin
2154 s:=pattern;
2155 sorg:=orgpattern;
2156 consume(_ID);
2157 consume(_COLON);
2158 srsym:=nil;
2159 obj:=tobjectdef(def);
2160 st:=obj.symtable;
2161 while (srsym=nil) and assigned(st) do
2162 begin
2163 srsym:=tsym(st.Find(s));
2164 if assigned(obj) then
2165 obj:=obj.childof;
2166 if assigned(obj) then
2167 st:=obj.symtable
2168 else
2169 st:=nil;
2170 end;
2171
2172 if (srsym=nil) or
2173 (srsym.typ<>fieldvarsym) then
2174 begin
2175 if (srsym=nil) then
2176 Message1(sym_e_id_not_found,sorg)
2177 else
2178 Message1(sym_e_illegal_field,sorg);
2179 consume_all_until(_RKLAMMER);
2180 break;
2181 end
2182 else
2183 with tfieldvarsym(srsym) do
2184 begin
2185 { check position }
2186 if fieldoffset<objoffset then
2187 message(parser_e_invalid_record_const);
2188
2189 { new position }
2190 objoffset:=fieldoffset+vardef.size;
2191
2192 { read the data }
2193 basenode:=csubscriptnode.create(srsym,orgbasenode.getcopy);
2194 read_typed_const_data(vardef);
2195
2196 if not try_to_consume(_SEMICOLON) then
2197 break;
2198 end;
2199 end;
2200 consume(_RKLAMMER);
2201 end;
2202
2203
2204 procedure tnodetreetypedconstbuilder.tc_emit_orddef(def: torddef; var node: tnode);
2205 begin
2206 addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
2207 basenode:=nil;
2208 node:=nil;
2209 end;
2210
2211
2212 procedure tnodetreetypedconstbuilder.tc_emit_floatdef(def: tfloatdef; var node: tnode);
2213 begin
2214 addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
2215 basenode:=nil;
2216 node:=nil;
2217 end;
2218
2219
2220 procedure tnodetreetypedconstbuilder.tc_emit_classrefdef(def: tclassrefdef; var node: tnode);
2221 begin
2222 addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
2223 basenode:=nil;
2224 node:=nil;
2225 end;
2226
2227
2228 procedure tnodetreetypedconstbuilder.tc_emit_pointerdef(def: tpointerdef; var node: tnode);
2229 begin
2230 addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
2231 basenode:=nil;
2232 node:=nil;
2233 end;
2234
2235
2236 procedure tnodetreetypedconstbuilder.tc_emit_setdef(def: tsetdef; var node: tnode);
2237 begin
2238 addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
2239 basenode:=nil;
2240 node:=nil;
2241 end;
2242
2243
2244 procedure tnodetreetypedconstbuilder.tc_emit_enumdef(def: tenumdef; var node: tnode);
2245 begin
2246 addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
2247 basenode:=nil;
2248 node:=nil;
2249 end;
2250
2251
2252 procedure tnodetreetypedconstbuilder.tc_emit_stringdef(def: tstringdef; var node: tnode);
2253 begin
2254 addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
2255 basenode:=nil;
2256 node:=nil;
2257 end;
2258
2259
2260 constructor tnodetreetypedconstbuilder.create(sym: tstaticvarsym; previnit: tnode);
2261 begin
2262 inherited create(sym);
2263 basenode:=cloadnode.create(sym,sym.owner);
2264 resultblock:=internalstatements(statmnt);
2265 if assigned(previnit) then
2266 addstatement(statmnt,previnit);
2267 end;
2268
2269
2270 destructor tnodetreetypedconstbuilder.destroy;
2271 begin
2272 freeandnil(basenode);
2273 freeandnil(resultblock);
2274 inherited destroy;
2275 end;
2276
2277
tnodetreetypedconstbuilder.parse_into_nodetreenull2278 function tnodetreetypedconstbuilder.parse_into_nodetree: tnode;
2279 begin
2280 read_typed_const_data(tcsym.vardef);
2281 result:=self.resultblock;
2282 self.resultblock:=nil;
2283 end;
2284
2285 begin
2286 { default to asmlist version, best for most targets }
2287 ctypedconstbuilder:=tasmlisttypedconstbuilder;
2288 end.
2289