1 { 2 Copyright (c) 2000-2002 by Florian Klaempfl 3 4 Type checking and register allocation for constants 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 ncon; 23 24 {$i fpcdefs.inc} 25 26 interface 27 28 uses 29 globtype,widestr,constexp, 30 node, 31 aasmbase,cpuinfo,globals, 32 symconst,symtype,symdef,symsym; 33 34 type 35 trealconstnode = class(tnode) 36 typedef : tdef; 37 typedefderef : tderef; 38 value_real : bestreal; 39 value_currency : currency; 40 lab_real : tasmlabel; 41 constructor create(v : bestreal;def:tdef);virtual; 42 constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override; 43 procedure ppuwrite(ppufile:tcompilerppufile);override; 44 procedure buildderefimpl;override; 45 procedure derefimpl;override; dogetcopynull46 function dogetcopy : tnode;override; pass_1null47 function pass_1 : tnode;override; pass_typechecknull48 function pass_typecheck:tnode;override; docomparenull49 function docompare(p: tnode) : boolean; override; 50 procedure printnodedata(var t:text);override; 51 end; 52 trealconstnodeclass = class of trealconstnode; 53 54 tordconstnode = class(tnode) 55 typedef : tdef; 56 typedefderef : tderef; 57 value : TConstExprInt; 58 rangecheck : boolean; 59 { create an ordinal constant node of the specified type and value. 60 _rangecheck determines if the value of the ordinal should be checked 61 against the ranges of the type definition. 62 } 63 constructor create(const v : tconstexprint;def:tdef; _rangecheck : boolean);virtual; 64 constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override; 65 procedure ppuwrite(ppufile:tcompilerppufile);override; 66 procedure buildderefimpl;override; 67 procedure derefimpl;override; dogetcopynull68 function dogetcopy : tnode;override; pass_1null69 function pass_1 : tnode;override; pass_typechecknull70 function pass_typecheck:tnode;override; docomparenull71 function docompare(p: tnode) : boolean; override; 72 procedure printnodedata(var t:text);override; 73 end; 74 tordconstnodeclass = class of tordconstnode; 75 76 tpointerconstnode = class(tnode) 77 typedef : tdef; 78 typedefderef : tderef; 79 value : TConstPtrUInt; 80 constructor create(v : TConstPtrUInt;def:tdef);virtual; 81 constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override; 82 procedure ppuwrite(ppufile:tcompilerppufile);override; 83 procedure buildderefimpl;override; 84 procedure derefimpl;override; dogetcopynull85 function dogetcopy : tnode;override; pass_1null86 function pass_1 : tnode;override; pass_typechecknull87 function pass_typecheck:tnode;override; docomparenull88 function docompare(p: tnode) : boolean; override; 89 procedure printnodedata(var t : text); override; 90 end; 91 tpointerconstnodeclass = class of tpointerconstnode; 92 93 tconststringtype = ( 94 cst_conststring, 95 cst_shortstring, 96 cst_longstring, 97 cst_ansistring, 98 cst_widestring, 99 cst_unicodestring 100 ); 101 102 tstringconstnode = class(tnode) 103 value_str : pchar; 104 len : longint; 105 lab_str : tasmlabel; 106 astringdef : tdef; 107 astringdefderef : tderef; 108 cst_type : tconststringtype; 109 constructor createstr(const s : string);virtual; 110 constructor createpchar(s: pchar; l: longint; def: tdef);virtual; 111 constructor createunistr(w : pcompilerwidestring);virtual; 112 constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override; 113 procedure ppuwrite(ppufile:tcompilerppufile);override; 114 procedure buildderefimpl;override; 115 procedure derefimpl;override; 116 destructor destroy;override; dogetcopynull117 function dogetcopy : tnode;override; pass_1null118 function pass_1 : tnode;override; pass_typechecknull119 function pass_typecheck:tnode;override; getpcharcopynull120 function getpcharcopy : pchar; docomparenull121 function docompare(p: tnode) : boolean; override; 122 procedure changestringtype(def:tdef); fullcomparenull123 function fullcompare(p: tstringconstnode): longint; 124 { returns whether this platform uses the nil pointer to represent 125 empty dynamic strings } emptydynstrnilnull126 class function emptydynstrnil: boolean; virtual; 127 end; 128 tstringconstnodeclass = class of tstringconstnode; 129 130 tsetconstnode = class(tunarynode) 131 typedef : tdef; 132 typedefderef : tderef; 133 value_set : pconstset; 134 lab_set : tasmsymbol; 135 constructor create(s : pconstset;def:tdef);virtual; 136 destructor destroy;override; 137 constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override; 138 procedure ppuwrite(ppufile:tcompilerppufile);override; 139 procedure buildderefimpl;override; 140 procedure derefimpl;override; 141 procedure adjustforsetbase; dogetcopynull142 function dogetcopy : tnode;override; pass_1null143 function pass_1 : tnode;override; pass_typechecknull144 function pass_typecheck:tnode;override; docomparenull145 function docompare(p: tnode) : boolean; override; elementsnull146 function elements : AInt; 147 end; 148 tsetconstnodeclass = class of tsetconstnode; 149 150 tnilnode = class(tnode) 151 constructor create;virtual; pass_1null152 function pass_1 : tnode;override; pass_typechecknull153 function pass_typecheck:tnode;override; 154 end; 155 tnilnodeclass = class of tnilnode; 156 157 tguidconstnode = class(tnode) 158 value : tguid; 159 lab_set : tasmsymbol; 160 constructor create(const g:tguid);virtual; 161 constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override; 162 procedure ppuwrite(ppufile:tcompilerppufile);override; dogetcopynull163 function dogetcopy : tnode;override; pass_1null164 function pass_1 : tnode;override; pass_typechecknull165 function pass_typecheck:tnode;override; docomparenull166 function docompare(p: tnode) : boolean; override; 167 end; 168 tguidconstnodeclass = class of tguidconstnode; 169 170 var 171 crealconstnode : trealconstnodeclass = trealconstnode; 172 cordconstnode : tordconstnodeclass = tordconstnode; 173 cpointerconstnode : tpointerconstnodeclass = tpointerconstnode; 174 cstringconstnode : tstringconstnodeclass = tstringconstnode; 175 csetconstnode : tsetconstnodeclass = tsetconstnode; 176 cguidconstnode : tguidconstnodeclass = tguidconstnode; 177 cnilnode : tnilnodeclass=tnilnode; 178 genintconstnodenull179 function genintconstnode(const v : TConstExprInt) : tordconstnode; genenumnodenull180 function genenumnode(v : tenumsym) : tordconstnode; 181 182 { some helper routines } get_ordinal_valuenull183 function get_ordinal_value(p : tnode) : TConstExprInt; get_string_valuenull184 function get_string_value(p : tnode; def: tstringdef) : tstringconstnode; is_constresourcestringnodenull185 function is_constresourcestringnode(p : tnode) : boolean; is_emptysetnull186 function is_emptyset(p : tnode):boolean; genconstsymtreenull187 function genconstsymtree(p : tconstsym) : tnode; 188 getbooleanvaluenull189 function getbooleanvalue(p : tnode) : boolean; 190 191 implementation 192 193 uses 194 cutils, 195 verbose,systems,sysutils, 196 defcmp,defutil,procinfo, 197 cgbase, 198 nld; 199 genintconstnodenull200 function genintconstnode(const v : TConstExprInt) : tordconstnode; 201 var 202 htype : tdef; 203 begin 204 int_to_type(v,htype); 205 genintconstnode:=cordconstnode.create(v,htype,true); 206 end; 207 208 genenumnodenull209 function genenumnode(v : tenumsym) : tordconstnode; 210 var 211 htype : tdef; 212 begin 213 htype:=v.definition; 214 genenumnode:=cordconstnode.create(int64(v.value),htype,true); 215 end; 216 217 get_ordinal_valuenull218 function get_ordinal_value(p : tnode) : TConstExprInt; 219 begin 220 get_ordinal_value:=0; 221 if is_constnode(p) then 222 begin 223 if p.nodetype=ordconstn then 224 get_ordinal_value:=tordconstnode(p).value 225 else 226 Message(type_e_ordinal_expr_expected); 227 end 228 else 229 Message(type_e_constant_expr_expected); 230 end; 231 get_string_valuenull232 function get_string_value(p: tnode; def: tstringdef): tstringconstnode; 233 var 234 stringVal: string; 235 pWideStringVal: pcompilerwidestring; 236 begin 237 stringVal:=''; 238 if is_constcharnode(p) then 239 begin 240 SetLength(stringVal,1); 241 stringVal[1]:=char(tordconstnode(p).value.uvalue); 242 result:=cstringconstnode.createstr(stringVal); 243 end 244 else if is_constwidecharnode(p) then 245 begin 246 initwidestring(pWideStringVal); 247 concatwidestringchar(pWideStringVal, tcompilerwidechar(tordconstnode(p).value.uvalue)); 248 result:=cstringconstnode.createunistr(pWideStringVal); 249 end 250 else if p.nodetype=stringconstn then 251 result:=tstringconstnode(p.getcopy) 252 else 253 begin 254 Message(type_e_string_expr_expected); 255 stringVal:=''; 256 result:=cstringconstnode.createstr(stringVal); 257 end; 258 result.changestringtype(def); 259 end; 260 261 is_constresourcestringnodenull262 function is_constresourcestringnode(p : tnode) : boolean; 263 begin 264 is_constresourcestringnode:=(p.nodetype=loadn) and 265 (tloadnode(p).symtableentry.typ=constsym) and 266 (tconstsym(tloadnode(p).symtableentry).consttyp=constresourcestring); 267 end; 268 269 is_emptysetnull270 function is_emptyset(p : tnode):boolean; 271 begin 272 is_emptyset:=(p.nodetype=setconstn) and 273 (Tsetconstnode(p).value_set^=[]); 274 end; 275 276 genconstsymtreenull277 function genconstsymtree(p : tconstsym) : tnode; 278 var 279 p1 : tnode; 280 len : longint; 281 pc : pchar; 282 begin 283 p1:=nil; 284 case p.consttyp of 285 constord : 286 begin 287 if p.constdef=nil then 288 internalerror(200403232); 289 p1:=cordconstnode.create(p.value.valueord,p.constdef,true); 290 end; 291 conststring : 292 begin 293 len:=p.value.len; 294 if not(cs_refcountedstrings in current_settings.localswitches) and (len>255) then 295 begin 296 message(parser_e_string_const_too_long); 297 len:=255; 298 end; 299 getmem(pc,len+1); 300 move(pchar(p.value.valueptr)^,pc^,len); 301 pc[len]:=#0; 302 p1:=cstringconstnode.createpchar(pc,len,p.constdef); 303 end; 304 constwstring : 305 p1:=cstringconstnode.createunistr(pcompilerwidestring(p.value.valueptr)); 306 constreal : 307 p1:=crealconstnode.create(pbestreal(p.value.valueptr)^,p.constdef); 308 constset : 309 p1:=csetconstnode.create(pconstset(p.value.valueptr),p.constdef); 310 constpointer : 311 p1:=cpointerconstnode.create(p.value.valueordptr,p.constdef); 312 constnil : 313 p1:=cnilnode.create; 314 constguid : 315 p1:=cguidconstnode.create(pguid(p.value.valueptr)^); 316 else 317 internalerror(200205103); 318 end; 319 genconstsymtree:=p1; 320 end; 321 322 getbooleanvaluenull323 function getbooleanvalue(p : tnode) : boolean; 324 begin 325 if is_constboolnode(p) then 326 result:=tordconstnode(p).value<>0 327 else 328 internalerror(2013111601); 329 end; 330 331 {***************************************************************************** 332 TREALCONSTNODE 333 *****************************************************************************} 334 335 { generic code } 336 { overridden by: } 337 { i386 } 338 constructor trealconstnode.create(v : bestreal;def:tdef); 339 begin 340 if current_settings.fputype=fpu_none then 341 internalerror(2008022401); 342 inherited create(realconstn); 343 typedef:=def; 344 case tfloatdef(def).floattype of 345 s32real: 346 v:=single(v); 347 s64real: 348 v:=double(v); 349 s80real, 350 sc80real, 351 s64comp, 352 s64currency: 353 v:=extended(v); 354 s128real: 355 internalerror(2013102701); 356 else 357 internalerror(2013102702); 358 end; 359 value_real:=v; 360 value_currency:=v; 361 lab_real:=nil; 362 end; 363 364 constructor trealconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile); 365 var 366 i : int64; 367 begin 368 inherited ppuload(t,ppufile); 369 ppufile.getderef(typedefderef); 370 value_real:=ppufile.getreal; 371 i:=ppufile.getint64; 372 value_currency:=PCurrency(@i)^; 373 lab_real:=tasmlabel(ppufile.getasmsymbol); 374 end; 375 376 377 procedure trealconstnode.ppuwrite(ppufile:tcompilerppufile); 378 begin 379 inherited ppuwrite(ppufile); 380 ppufile.putderef(typedefderef); 381 ppufile.putreal(value_real); 382 ppufile.putint64(PInt64(@value_currency)^); 383 ppufile.putasmsymbol(lab_real); 384 end; 385 386 387 procedure trealconstnode.buildderefimpl; 388 begin 389 inherited buildderefimpl; 390 typedefderef.build(typedef); 391 end; 392 393 394 procedure trealconstnode.derefimpl; 395 begin 396 inherited derefimpl; 397 typedef:=tdef(typedefderef.resolve); 398 end; 399 400 trealconstnode.dogetcopynull401 function trealconstnode.dogetcopy : tnode; 402 var 403 n : trealconstnode; 404 begin 405 n:=trealconstnode(inherited dogetcopy); 406 n.typedef:=typedef; 407 n.value_real:=value_real; 408 n.value_currency:=value_currency; 409 n.lab_real:=lab_real; 410 dogetcopy:=n; 411 end; 412 413 trealconstnode.pass_typechecknull414 function trealconstnode.pass_typecheck:tnode; 415 begin 416 result:=nil; 417 resultdef:=typedef; 418 419 { range checking? } 420 if floating_point_range_check_error or 421 (tfloatdef(resultdef).floattype in [s64comp,s64currency]) then 422 begin 423 { use CGMessage so that the resultdef will get set to errordef 424 by pass1.typecheckpass_internal if a range error was triggered, 425 which in turn will prevent any potential parent type conversion 426 node from creating a new realconstnode with this exact same value 427 and hence trigger the same error again } 428 case tfloatdef(resultdef).floattype of 429 s32real : 430 begin 431 if ts32real(value_real)=MathInf.Value then 432 CGMessage(parser_e_range_check_error); 433 end; 434 s64real: 435 begin 436 if ts64real(value_real)=MathInf.Value then 437 CGMessage(parser_e_range_check_error); 438 end; 439 s80real, 440 sc80real: 441 begin 442 if ts80real(value_real)=MathInf.Value then 443 CGMessage(parser_e_range_check_error); 444 end; 445 s64comp, 446 s64currency: 447 begin 448 if (value_real>9223372036854775807.0) or 449 (value_real<-9223372036854775808.0) then 450 CGMessage(parser_e_range_check_error) 451 end; 452 s128real: 453 begin 454 if ts128real(value_real)=MathInf.Value then 455 CGMessage(parser_e_range_check_error); 456 end; 457 else 458 internalerror(2016112902); 459 end; 460 end; 461 end; 462 463 trealconstnode.pass_1null464 function trealconstnode.pass_1 : tnode; 465 begin 466 result:=nil; 467 expectloc:=LOC_CREFERENCE; 468 if (cs_create_pic in current_settings.moduleswitches) then 469 include(current_procinfo.flags,pi_needs_got); 470 end; 471 472 trealconstnode.docomparenull473 function trealconstnode.docompare(p: tnode): boolean; 474 begin 475 docompare := 476 inherited docompare(p) and 477 { this should be always true } 478 (trealconstnode(p).typedef.typ=floatdef) and (typedef.typ=floatdef) and 479 (tfloatdef(typedef).floattype = tfloatdef(trealconstnode(p).typedef).floattype) and 480 ( 481 ( 482 (tfloatdef(typedef).floattype=s64currency) and 483 (value_currency=trealconstnode(p).value_currency) 484 ) 485 or 486 ( 487 (tfloatdef(typedef).floattype<>s64currency) and 488 (value_real = trealconstnode(p).value_real) and 489 { floating point compares for non-numbers give strange results usually } 490 is_number_float(value_real) and 491 is_number_float(trealconstnode(p).value_real) 492 ) 493 ); 494 end; 495 496 497 procedure Trealconstnode.printnodedata(var t:text); 498 begin 499 inherited printnodedata(t); 500 write(t,printnodeindention,'value = ',value_real); 501 if is_currency(resultdef) then 502 writeln(', value_currency = ',value_currency) 503 else 504 writeln; 505 end; 506 507 508 {***************************************************************************** 509 TORDCONSTNODE 510 *****************************************************************************} 511 512 constructor tordconstnode.create(const v : tconstexprint;def:tdef;_rangecheck : boolean); 513 514 begin 515 inherited create(ordconstn); 516 value:=v; 517 typedef:=def; 518 rangecheck := _rangecheck; 519 end; 520 521 522 constructor tordconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile); 523 begin 524 inherited ppuload(t,ppufile); 525 ppufile.getderef(typedefderef); 526 value:=ppufile.getexprint; 527 { normally, the value is already compiled, so we don't need 528 to do once again a range check 529 } 530 rangecheck := false; 531 end; 532 533 534 procedure tordconstnode.ppuwrite(ppufile:tcompilerppufile); 535 begin 536 inherited ppuwrite(ppufile); 537 ppufile.putderef(typedefderef); 538 ppufile.putexprint(value); 539 end; 540 541 542 procedure tordconstnode.buildderefimpl; 543 begin 544 inherited buildderefimpl; 545 typedefderef.build(typedef); 546 end; 547 548 549 procedure tordconstnode.derefimpl; 550 begin 551 inherited derefimpl; 552 typedef:=tdef(typedefderef.resolve); 553 end; 554 555 tordconstnode.dogetcopynull556 function tordconstnode.dogetcopy : tnode; 557 558 var 559 n : tordconstnode; 560 561 begin 562 n:=tordconstnode(inherited dogetcopy); 563 n.value:=value; 564 n.typedef := typedef; 565 dogetcopy:=n; 566 end; 567 tordconstnode.pass_typechecknull568 function tordconstnode.pass_typecheck:tnode; 569 begin 570 result:=nil; 571 resultdef:=typedef; 572 { only do range checking when explicitly asked for it 573 and if the type can be range checked, see tests/tbs/tb0539.pp } 574 if (resultdef.typ in [orddef,enumdef]) then 575 adaptrange(resultdef,value,nf_internal in flags,not rangecheck,rangecheck) 576 end; 577 tordconstnode.pass_1null578 function tordconstnode.pass_1 : tnode; 579 begin 580 result:=nil; 581 expectloc:=LOC_CONSTANT; 582 end; 583 tordconstnode.docomparenull584 function tordconstnode.docompare(p: tnode): boolean; 585 begin 586 docompare := 587 inherited docompare(p) and 588 (value = tordconstnode(p).value) and 589 equal_defs(typedef,tordconstnode(p).typedef); 590 end; 591 592 593 procedure Tordconstnode.printnodedata(var t:text); 594 begin 595 inherited printnodedata(t); 596 writeln(t,printnodeindention,'value = ',tostr(value)); 597 end; 598 599 600 {***************************************************************************** 601 TPOINTERCONSTNODE 602 *****************************************************************************} 603 604 constructor tpointerconstnode.create(v : TConstPtrUInt;def:tdef); 605 606 begin 607 inherited create(pointerconstn); 608 value:=v; 609 typedef:=def; 610 end; 611 612 613 constructor tpointerconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile); 614 begin 615 inherited ppuload(t,ppufile); 616 ppufile.getderef(typedefderef); 617 value:=ppufile.getptruint; 618 end; 619 620 621 procedure tpointerconstnode.ppuwrite(ppufile:tcompilerppufile); 622 begin 623 inherited ppuwrite(ppufile); 624 ppufile.putderef(typedefderef); 625 ppufile.putptruint(value); 626 end; 627 628 629 procedure tpointerconstnode.buildderefimpl; 630 begin 631 inherited buildderefimpl; 632 typedefderef.build(typedef); 633 end; 634 635 636 procedure tpointerconstnode.derefimpl; 637 begin 638 inherited derefimpl; 639 typedef:=tdef(typedefderef.resolve); 640 end; 641 642 tpointerconstnode.dogetcopynull643 function tpointerconstnode.dogetcopy : tnode; 644 645 var 646 n : tpointerconstnode; 647 648 begin 649 n:=tpointerconstnode(inherited dogetcopy); 650 n.value:=value; 651 n.typedef := typedef; 652 dogetcopy:=n; 653 end; 654 tpointerconstnode.pass_typechecknull655 function tpointerconstnode.pass_typecheck:tnode; 656 begin 657 result:=nil; 658 resultdef:=typedef; 659 end; 660 tpointerconstnode.pass_1null661 function tpointerconstnode.pass_1 : tnode; 662 begin 663 result:=nil; 664 expectloc:=LOC_CONSTANT; 665 end; 666 tpointerconstnode.docomparenull667 function tpointerconstnode.docompare(p: tnode): boolean; 668 begin 669 docompare := 670 inherited docompare(p) and 671 (value = tpointerconstnode(p).value); 672 end; 673 674 675 procedure tpointerconstnode.printnodedata(var t : text); 676 begin 677 inherited printnodedata(t); 678 writeln(t,printnodeindention,'value = $',hexstr(PUInt(value),sizeof(PUInt)*2)); 679 end; 680 681 682 {***************************************************************************** 683 TSTRINGCONSTNODE 684 *****************************************************************************} 685 686 constructor tstringconstnode.createstr(const s : string); 687 var 688 l : longint; 689 begin 690 inherited create(stringconstn); 691 l:=length(s); 692 len:=l; 693 { stringdup write even past a #0 } 694 getmem(value_str,l+1); 695 move(s[1],value_str^,l); 696 value_str[l]:=#0; 697 lab_str:=nil; 698 cst_type:=cst_conststring; 699 end; 700 701 702 constructor tstringconstnode.createunistr(w : pcompilerwidestring); 703 begin 704 inherited create(stringconstn); 705 len:=getlengthwidestring(w); 706 initwidestring(pcompilerwidestring(value_str)); 707 copywidestring(w,pcompilerwidestring(value_str)); 708 lab_str:=nil; 709 cst_type:=cst_unicodestring; 710 end; 711 712 713 constructor tstringconstnode.createpchar(s: pchar; l: longint; def: tdef); 714 begin 715 inherited create(stringconstn); 716 len:=l; 717 value_str:=s; 718 if assigned(def) and 719 is_ansistring(def) then 720 begin 721 cst_type:=cst_ansistring; 722 astringdef:=def; 723 end 724 else 725 cst_type:=cst_conststring; 726 lab_str:=nil; 727 end; 728 729 730 destructor tstringconstnode.destroy; 731 begin 732 if cst_type in [cst_widestring,cst_unicodestring] then 733 donewidestring(pcompilerwidestring(value_str)) 734 else 735 ansistringdispose(value_str,len); 736 inherited destroy; 737 end; 738 739 740 constructor tstringconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile); 741 var 742 pw : pcompilerwidestring; 743 i : longint; 744 begin 745 inherited ppuload(t,ppufile); 746 cst_type:=tconststringtype(ppufile.getbyte); 747 len:=ppufile.getlongint; 748 if cst_type in [cst_widestring,cst_unicodestring] then 749 begin 750 initwidestring(pw); 751 setlengthwidestring(pw,len); 752 { don't use getdata, because the compilerwidechars may have to 753 be byteswapped 754 } 755 {$if sizeof(tcompilerwidechar) = 2} 756 for i:=0 to pw^.len-1 do 757 pw^.data[i]:=ppufile.getword; 758 {$elseif sizeof(tcompilerwidechar) = 4} 759 for i:=0 to pw^.len-1 do 760 pw^.data[i]:=cardinal(ppufile.getlongint); 761 {$else} 762 {$error Unsupported tcompilerwidechar size} 763 {$endif} 764 pcompilerwidestring(value_str):=pw 765 end 766 else 767 begin 768 getmem(value_str,len+1); 769 ppufile.getdata(value_str^,len); 770 value_str[len]:=#0; 771 end; 772 lab_str:=tasmlabel(ppufile.getasmsymbol); 773 if cst_type=cst_ansistring then 774 ppufile.getderef(astringdefderef); 775 end; 776 777 778 procedure tstringconstnode.ppuwrite(ppufile:tcompilerppufile); 779 begin 780 inherited ppuwrite(ppufile); 781 ppufile.putbyte(byte(cst_type)); 782 ppufile.putlongint(len); 783 if cst_type in [cst_widestring,cst_unicodestring] then 784 ppufile.putdata(pcompilerwidestring(value_str)^.data^,len*sizeof(tcompilerwidechar)) 785 else 786 ppufile.putdata(value_str^,len); 787 ppufile.putasmsymbol(lab_str); 788 if cst_type=cst_ansistring then 789 ppufile.putderef(astringdefderef); 790 end; 791 792 793 procedure tstringconstnode.buildderefimpl; 794 begin 795 inherited buildderefimpl; 796 if cst_type=cst_ansistring then 797 astringdefderef.build(astringdef); 798 end; 799 800 801 procedure tstringconstnode.derefimpl; 802 begin 803 inherited derefimpl; 804 if cst_type=cst_ansistring then 805 astringdef:=tdef(astringdefderef.resolve); 806 end; 807 808 tstringconstnode.dogetcopynull809 function tstringconstnode.dogetcopy : tnode; 810 811 var 812 n : tstringconstnode; 813 814 begin 815 n:=tstringconstnode(inherited dogetcopy); 816 n.cst_type:=cst_type; 817 n.len:=len; 818 n.lab_str:=lab_str; 819 if cst_type in [cst_widestring,cst_unicodestring] then 820 begin 821 initwidestring(pcompilerwidestring(n.value_str)); 822 copywidestring(pcompilerwidestring(value_str),pcompilerwidestring(n.value_str)); 823 end 824 else 825 n.value_str:=getpcharcopy; 826 n.astringdef:=astringdef; 827 dogetcopy:=n; 828 end; 829 tstringconstnode.pass_typechecknull830 function tstringconstnode.pass_typecheck:tnode; 831 var 832 l : aint; 833 begin 834 result:=nil; 835 case cst_type of 836 cst_conststring : 837 begin 838 { handle and store as array[0..len-1] of char } 839 if len>0 then 840 l:=len-1 841 else 842 l:=0; 843 resultdef:=carraydef.create(0,l,s32inttype); 844 tarraydef(resultdef).elementdef:=cansichartype; 845 include(tarraydef(resultdef).arrayoptions,ado_IsConstString); 846 end; 847 cst_shortstring : 848 resultdef:=cshortstringtype; 849 cst_ansistring : 850 if not assigned(astringdef) then 851 resultdef:=getansistringdef 852 else 853 resultdef:=astringdef; 854 cst_unicodestring : 855 resultdef:=cunicodestringtype; 856 cst_widestring : 857 resultdef:=cwidestringtype; 858 cst_longstring : 859 resultdef:=clongstringtype; 860 end; 861 end; 862 tstringconstnode.pass_1null863 function tstringconstnode.pass_1 : tnode; 864 begin 865 result:=nil; 866 if (cst_type in [cst_ansistring,cst_widestring,cst_unicodestring]) then 867 begin 868 if len=0 then 869 expectloc:=LOC_CONSTANT 870 else 871 expectloc:=LOC_REGISTER 872 end 873 else 874 expectloc:=LOC_CREFERENCE; 875 if (cs_create_pic in current_settings.moduleswitches) and 876 (expectloc <> LOC_CONSTANT) then 877 include(current_procinfo.flags,pi_needs_got); 878 end; 879 880 tstringconstnode.getpcharcopynull881 function tstringconstnode.getpcharcopy : pchar; 882 var 883 pc : pchar; 884 begin 885 pc:=nil; 886 getmem(pc,len+1); 887 if pc=nil then 888 Message(general_f_no_memory_left); 889 move(value_str^,pc^,len+1); 890 getpcharcopy:=pc; 891 end; 892 tstringconstnode.docomparenull893 function tstringconstnode.docompare(p: tnode): boolean; 894 begin 895 docompare := 896 inherited docompare(p) and 897 (len = tstringconstnode(p).len) and 898 (lab_str = tstringconstnode(p).lab_str) and 899 { This is enough as soon as labels are allocated, otherwise } 900 { fall back to content compare. } 901 (assigned(lab_str) or 902 (cst_type = tstringconstnode(p).cst_type) and 903 (fullcompare(tstringconstnode(p)) = 0)) 904 ; 905 end; 906 907 908 procedure tstringconstnode.changestringtype(def:tdef); 909 const 910 st2cst : array[tstringtype] of tconststringtype = ( 911 cst_shortstring,cst_longstring,cst_ansistring,cst_widestring,cst_unicodestring); 912 var 913 pw : pcompilerwidestring; 914 pc : pchar; 915 cp1 : tstringencoding; 916 cp2 : tstringencoding; 917 l,l2 : longint; 918 begin 919 if def.typ<>stringdef then 920 internalerror(200510011); 921 { convert ascii 2 unicode } 922 if (tstringdef(def).stringtype in [st_widestring,st_unicodestring]) and 923 not(cst_type in [cst_widestring,cst_unicodestring]) then 924 begin 925 initwidestring(pw); 926 ascii2unicode(value_str,len,current_settings.sourcecodepage,pw); 927 ansistringdispose(value_str,len); 928 pcompilerwidestring(value_str):=pw; 929 end 930 else 931 { convert unicode 2 ascii } 932 if (cst_type in [cst_widestring,cst_unicodestring]) and 933 not(tstringdef(def).stringtype in [st_widestring,st_unicodestring]) then 934 begin 935 cp1:=tstringdef(def).encoding; 936 if (cp1=globals.CP_NONE) or (cp1=0) then 937 cp1:=current_settings.sourcecodepage; 938 if (cp1=CP_UTF8) then 939 begin 940 pw:=pcompilerwidestring(value_str); 941 l2:=len; 942 l:=UnicodeToUtf8(nil,0,PUnicodeChar(pw^.data),l2); 943 getmem(pc,l); 944 UnicodeToUtf8(pc,l,PUnicodeChar(pw^.data),l2); 945 len:=l-1; 946 donewidestring(pw); 947 value_str:=pc; 948 end 949 else 950 begin 951 pw:=pcompilerwidestring(value_str); 952 getmem(pc,getlengthwidestring(pw)+1); 953 unicode2ascii(pw,pc,cp1); 954 donewidestring(pw); 955 value_str:=pc; 956 end; 957 end 958 else 959 if (tstringdef(def).stringtype = st_ansistring) and 960 not(cst_type in [cst_widestring,cst_unicodestring]) then 961 begin 962 cp1:=tstringdef(def).encoding; 963 if cp1=0 then 964 cp1:=current_settings.sourcecodepage; 965 if (cst_type = cst_ansistring) then 966 begin 967 cp2:=tstringdef(resultdef).encoding; 968 if cp2=0 then 969 cp2:=current_settings.sourcecodepage; 970 end 971 else if (cst_type in [cst_shortstring,cst_conststring,cst_longstring]) then 972 cp2:=current_settings.sourcecodepage 973 else 974 internalerror(2013112916); 975 { don't change string if codepages are equal or string length is 0 } 976 if (cp1<>cp2) and (len>0) then 977 begin 978 if cpavailable(cp1) and cpavailable(cp2) then 979 changecodepage(value_str,len,cp2,value_str,cp1) 980 else if (cp1 <> globals.CP_NONE) and (cp2 <> globals.CP_NONE) then 981 begin 982 { if source encoding is UTF8 convert using UTF8->UTF16->destination encoding } 983 if (cp2=CP_UTF8) then 984 begin 985 if not cpavailable(cp1) then 986 Message1(option_code_page_not_available,IntToStr(cp1)); 987 initwidestring(pw); 988 setlengthwidestring(pw,len); 989 { returns room for terminating 0 } 990 l:=Utf8ToUnicode(PUnicodeChar(pw^.data),len,value_str,len); 991 if (l<>getlengthwidestring(pw)) then 992 begin 993 setlengthwidestring(pw,l); 994 ReAllocMem(value_str,l); 995 end; 996 unicode2ascii(pw,value_str,cp1); 997 len:=l-1; 998 donewidestring(pw); 999 end 1000 else 1001 { if destination encoding is UTF8 convert using source encoding->UTF16->UTF8 } 1002 if (cp1=CP_UTF8) then 1003 begin 1004 if not cpavailable(cp2) then 1005 Message1(option_code_page_not_available,IntToStr(cp2)); 1006 initwidestring(pw); 1007 setlengthwidestring(pw,len); 1008 ascii2unicode(value_str,len,cp2,pw); 1009 { returns room for terminating 0 } 1010 l:=UnicodeToUtf8(nil,0,PUnicodeChar(pw^.data),len); 1011 if l<>len then 1012 ReAllocMem(value_str,l); 1013 len:=l-1; 1014 UnicodeToUtf8(value_str,PUnicodeChar(pw^.data),l); 1015 donewidestring(pw); 1016 end 1017 else 1018 begin 1019 { output error message that encoding is not available for the compiler } 1020 if not cpavailable(cp1) then 1021 Message1(option_code_page_not_available,IntToStr(cp1)); 1022 if not cpavailable(cp2) then 1023 Message1(option_code_page_not_available,IntToStr(cp2)); 1024 end; 1025 end; 1026 end; 1027 end; 1028 cst_type:=st2cst[tstringdef(def).stringtype]; 1029 resultdef:=def; 1030 end; 1031 tstringconstnode.fullcomparenull1032 function tstringconstnode.fullcompare(p: tstringconstnode): longint; 1033 begin 1034 if cst_type<>p.cst_type then 1035 InternalError(2009121701); 1036 if cst_type in [cst_widestring,cst_unicodestring] then 1037 result:=comparewidestrings(pcompilerwidestring(value_str),pcompilerwidestring(p.value_str)) 1038 else 1039 result:=compareansistrings(value_str,p.value_str,len,p.len); 1040 end; 1041 tstringconstnode.emptydynstrnilnull1042 class function tstringconstnode.emptydynstrnil: boolean; 1043 begin 1044 result:=true; 1045 end; 1046 1047 {***************************************************************************** 1048 TSETCONSTNODE 1049 *****************************************************************************} 1050 1051 constructor tsetconstnode.create(s : pconstset;def:tdef); 1052 1053 begin 1054 inherited create(setconstn,nil); 1055 typedef:=def; 1056 if assigned(s) then 1057 begin 1058 new(value_set); 1059 value_set^:=s^; 1060 end 1061 else 1062 value_set:=nil; 1063 end; 1064 1065 1066 destructor tsetconstnode.destroy; 1067 begin 1068 if assigned(value_set) then 1069 dispose(value_set); 1070 inherited destroy; 1071 end; 1072 1073 1074 constructor tsetconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile); 1075 begin 1076 inherited ppuload(t,ppufile); 1077 ppufile.getderef(typedefderef); 1078 new(value_set); 1079 ppufile.getnormalset(value_set^); 1080 end; 1081 1082 1083 procedure tsetconstnode.ppuwrite(ppufile:tcompilerppufile); 1084 begin 1085 inherited ppuwrite(ppufile); 1086 ppufile.putderef(typedefderef); 1087 ppufile.putnormalset(value_set^); 1088 end; 1089 1090 1091 procedure tsetconstnode.buildderefimpl; 1092 begin 1093 inherited buildderefimpl; 1094 typedefderef.build(typedef); 1095 end; 1096 1097 1098 procedure tsetconstnode.derefimpl; 1099 begin 1100 inherited derefimpl; 1101 typedef:=tdef(typedefderef.resolve); 1102 end; 1103 1104 type 1105 setbytes = array[0..31] of byte; 1106 Psetbytes = ^setbytes; 1107 1108 procedure tsetconstnode.adjustforsetbase; 1109 var 1110 i, diff: longint; 1111 begin 1112 { Internally, the compiler stores all sets with setbase 0, so we have } 1113 { to convert the set to its actual format in case setbase<>0 when } 1114 { writing it out } 1115 if (tsetdef(resultdef).setbase<>0) then 1116 begin 1117 if (tsetdef(resultdef).setbase and 7)<>0 then 1118 internalerror(2007091501); 1119 diff:=tsetdef(resultdef).setbase div 8; 1120 { This is endian-neutral in the new set format: in both cases, } 1121 { the first byte contains the first elements of the set. } 1122 { Since the compiler/base rtl cannot contain packed sets before } 1123 { they work for big endian, it's no problem that the code below } 1124 { is wrong for the old big endian set format (setbase cannot be } 1125 { <>0 with non-packed sets). } 1126 for i:=0 to tsetdef(resultdef).size-1 do 1127 begin 1128 Psetbytes(value_set)^[i]:=Psetbytes(value_set)^[i+diff]; 1129 Psetbytes(value_set)^[i+diff]:=0; 1130 end; 1131 end; 1132 end; 1133 1134 tsetconstnode.dogetcopynull1135 function tsetconstnode.dogetcopy : tnode; 1136 var 1137 n : tsetconstnode; 1138 begin 1139 n:=tsetconstnode(inherited dogetcopy); 1140 if assigned(value_set) then 1141 begin 1142 new(n.value_set); 1143 n.value_set^:=value_set^ 1144 end 1145 else 1146 n.value_set:=nil; 1147 n.typedef := typedef; 1148 n.lab_set:=lab_set; 1149 dogetcopy:=n; 1150 end; 1151 1152 tsetconstnode.pass_typechecknull1153 function tsetconstnode.pass_typecheck:tnode; 1154 begin 1155 result:=nil; 1156 resultdef:=typedef; 1157 end; 1158 1159 tsetconstnode.pass_1null1160 function tsetconstnode.pass_1 : tnode; 1161 begin 1162 result:=nil; 1163 if is_smallset(resultdef) then 1164 expectloc:=LOC_CONSTANT 1165 else 1166 expectloc:=LOC_CREFERENCE; 1167 if (cs_create_pic in current_settings.moduleswitches) and 1168 (expectloc <> LOC_CONSTANT) then 1169 include(current_procinfo.flags,pi_needs_got); 1170 end; 1171 1172 tsetconstnode.docomparenull1173 function tsetconstnode.docompare(p: tnode): boolean; 1174 begin 1175 docompare:=(inherited docompare(p)) and 1176 (value_set^=Tsetconstnode(p).value_set^); 1177 end; 1178 1179 tsetconstnode.elementsnull1180 function tsetconstnode.elements : AInt; 1181 var 1182 i : longint; 1183 begin 1184 result:=0; 1185 if not(assigned(value_set)) then 1186 exit; 1187 for i:=0 to tsetdef(resultdef).size-1 do 1188 result:=result+ PopCnt(Psetbytes(value_set)^[i]); 1189 end; 1190 1191 1192 {***************************************************************************** 1193 TNILNODE 1194 *****************************************************************************} 1195 1196 constructor tnilnode.create; 1197 1198 begin 1199 inherited create(niln); 1200 end; 1201 tnilnode.pass_typechecknull1202 function tnilnode.pass_typecheck:tnode; 1203 begin 1204 result:=nil; 1205 resultdef:=voidpointertype; 1206 end; 1207 tnilnode.pass_1null1208 function tnilnode.pass_1 : tnode; 1209 begin 1210 result:=nil; 1211 expectloc:=LOC_CONSTANT; 1212 end; 1213 1214 {***************************************************************************** 1215 TGUIDCONSTNODE 1216 *****************************************************************************} 1217 1218 constructor tguidconstnode.create(const g:tguid); 1219 1220 begin 1221 inherited create(guidconstn); 1222 value:=g; 1223 end; 1224 1225 constructor tguidconstnode.ppuload(t:tnodetype;ppufile:tcompilerppufile); 1226 begin 1227 inherited ppuload(t,ppufile); 1228 ppufile.getguid(value); 1229 end; 1230 1231 1232 procedure tguidconstnode.ppuwrite(ppufile:tcompilerppufile); 1233 begin 1234 inherited ppuwrite(ppufile); 1235 ppufile.putguid(value); 1236 end; 1237 1238 tguidconstnode.dogetcopynull1239 function tguidconstnode.dogetcopy : tnode; 1240 var 1241 n : tguidconstnode; 1242 begin 1243 n:=tguidconstnode(inherited dogetcopy); 1244 n.value:=value; 1245 n.lab_set:=lab_set; 1246 dogetcopy:=n; 1247 end; 1248 1249 tguidconstnode.pass_typechecknull1250 function tguidconstnode.pass_typecheck:tnode; 1251 begin 1252 result:=nil; 1253 resultdef:=rec_tguid; 1254 end; 1255 1256 tguidconstnode.pass_1null1257 function tguidconstnode.pass_1 : tnode; 1258 begin 1259 result:=nil; 1260 expectloc:=LOC_CREFERENCE; 1261 if (cs_create_pic in current_settings.moduleswitches) and 1262 (tf_pic_uses_got in target_info.flags) then 1263 include(current_procinfo.flags,pi_needs_got); 1264 end; 1265 1266 tguidconstnode.docomparenull1267 function tguidconstnode.docompare(p: tnode): boolean; 1268 begin 1269 docompare := 1270 inherited docompare(p) and 1271 (guid2string(value) = guid2string(tguidconstnode(p).value)); 1272 end; 1273 1274 end. 1275