1 { 2 Copyright (c) 1998-2002 by Florian Klaempfl 3 4 Generates nodes for routines that need compiler support 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 pinline; 23 24 {$i fpcdefs.inc} 25 26 interface 27 28 uses 29 symtype, 30 node, 31 globals; 32 new_dispose_statementnull33 function new_dispose_statement(is_new:boolean) : tnode; new_functionnull34 function new_function : tnode; 35 inline_setlengthnull36 function inline_setlength : tnode; inline_setstringnull37 function inline_setstring : tnode; inline_initializenull38 function inline_initialize : tnode; inline_finalizenull39 function inline_finalize : tnode; inline_copynull40 function inline_copy : tnode; inline_insertnull41 function inline_insert : tnode; inline_deletenull42 function inline_delete : tnode; inline_concatnull43 function inline_concat : tnode; 44 45 46 implementation 47 48 uses 49 { global } 50 globtype,tokens,verbose,constexp, 51 systems,compinnr, 52 { symtable } 53 symbase,symconst,symdef,symsym,symtable,defutil, 54 { pass 1 } 55 pass_1,htypechk, 56 ncal,nmem,ncnv,ninl,ncon,nld,nbas,ngenutil,nutils, 57 { parser } 58 scanner, 59 pbase,pexpr; 60 61 new_dispose_statementnull62 function new_dispose_statement(is_new:boolean) : tnode; 63 var 64 newstatement : tstatementnode; 65 temp : ttempcreatenode; 66 para : tcallparanode; 67 p,p2 : tnode; 68 again : boolean; { dummy for do_proc_call } 69 destructorname : TIDString; 70 sym : tsym; 71 classh : tobjectdef; 72 callflag : tcallnodeflag; 73 destructorpos, 74 storepos : tfileposinfo; 75 variantdesc : pvariantrecdesc; 76 found : boolean; 77 variantselectsymbol : tfieldvarsym; 78 79 procedure ReadVariantRecordConstants; 80 var 81 i,j : longint; 82 begin 83 if (([m_iso,m_extpas]*current_settings.modeswitches)<>[]) and (is_record(tpointerdef(p.resultdef).pointeddef)) then 84 begin 85 variantdesc:=trecorddef(tpointerdef(p.resultdef).pointeddef).variantrecdesc; 86 while (token=_COMMA) and assigned(variantdesc) do 87 begin 88 consume(_COMMA); 89 p2:=factor(false,[]); 90 do_typecheckpass(p2); 91 if p2.nodetype=ordconstn then 92 begin 93 found:=false; 94 { we do not have dynamic dfa, so avoid warning on variantselectsymbol below } 95 variantselectsymbol:=nil; 96 for i:=0 to high(variantdesc^.branches) do 97 begin 98 for j:=0 to high(variantdesc^.branches[i].values) do 99 if variantdesc^.branches[i].values[j]=tordconstnode(p2).value then 100 begin 101 found:=true; 102 variantselectsymbol:=tfieldvarsym(variantdesc^.variantselector); 103 variantdesc:=variantdesc^.branches[i].nestedvariant; 104 break; 105 end; 106 if found then 107 break; 108 end; 109 if found then 110 begin 111 if is_new then 112 begin 113 { if no tag-field is given, do not create an assignment statement for it } 114 if assigned(variantselectsymbol) then 115 { setup variant selector } 116 addstatement(newstatement,cassignmentnode.create( 117 csubscriptnode.create(variantselectsymbol, 118 cderefnode.create(ctemprefnode.create(temp))), 119 p2)); 120 end; 121 end 122 else 123 Message(parser_e_illegal_expression); 124 end 125 else 126 Message(parser_e_illegal_expression); 127 end; 128 end; 129 end; 130 131 begin 132 if target_info.system in systems_managed_vm then 133 message(parser_e_feature_unsupported_for_vm); 134 consume(_LKLAMMER); 135 p:=comp_expr([ef_accept_equal]); 136 { calc return type } 137 if is_new then 138 begin 139 set_varstate(p,vs_written,[]); 140 valid_for_var(p,true); 141 end 142 else 143 set_varstate(p,vs_readwritten,[vsf_must_be_valid]); 144 if (m_mac in current_settings.modeswitches) and 145 is_class(p.resultdef) then 146 begin 147 classh:=tobjectdef(p.resultdef); 148 149 { make sure we call ObjPas.TObject.Create/Free and not a random } 150 { create/free method in a macpas descendent object (since those } 151 { are not supposed to be called automatically when you call } 152 { new/dispose) } 153 while assigned(classh.childof) do 154 classh := classh.childof; 155 if is_new then 156 begin 157 sym:=search_struct_member(classh,'CREATE'); 158 p2 := cloadvmtaddrnode.create(ctypenode.create(p.resultdef)); 159 end 160 else 161 begin 162 sym:=search_struct_member(classh,'FREE'); 163 p2 := p; 164 end; 165 166 if not(assigned(sym)) then 167 begin 168 p.free; 169 if is_new then 170 p2.free; 171 new_dispose_statement := cerrornode.create; 172 consume_all_until(_RKLAMMER); 173 consume(_RKLAMMER); 174 exit; 175 end; 176 177 do_member_read(classh,false,sym,p2,again,[],nil); 178 179 { we need the real called method } 180 do_typecheckpass(p2); 181 182 if (p2.nodetype=calln) and 183 assigned(tcallnode(p2).procdefinition) then 184 begin 185 if is_new then 186 begin 187 if (tcallnode(p2).procdefinition.proctypeoption<>potype_constructor) then 188 Message(parser_e_expr_have_to_be_constructor_call); 189 p2.resultdef:=p.resultdef; 190 p2:=cassignmentnode.create(p,p2); 191 typecheckpass(p2); 192 end 193 else 194 begin 195 { Free is not a destructor 196 if (tcallnode(p2).procdefinition.proctypeoption<>potype_destructor) then 197 Message(parser_e_expr_have_to_be_destructor_call); 198 } 199 end 200 end 201 else 202 internalerror(2005061202); 203 new_dispose_statement := p2; 204 end 205 { constructor,destructor specified } 206 else if (([m_mac,m_iso,m_extpas]*current_settings.modeswitches)=[]) and 207 try_to_consume(_COMMA) then 208 begin 209 { extended syntax of new and dispose } 210 { function styled new is handled in factor } 211 { destructors have no parameters } 212 destructorname:=pattern; 213 destructorpos:=current_tokenpos; 214 consume(_ID); 215 216 if is_typeparam(p.resultdef) then 217 begin 218 p.free; 219 p:=factor(false,[]); 220 p.free; 221 consume(_RKLAMMER); 222 new_dispose_statement:=cnothingnode.create; 223 exit; 224 end; 225 226 if (p.resultdef.typ<>pointerdef) then 227 begin 228 Message1(type_e_pointer_type_expected,p.resultdef.typename); 229 p.free; 230 p:=factor(false,[]); 231 p.free; 232 consume(_RKLAMMER); 233 new_dispose_statement:=cerrornode.create; 234 exit; 235 end; 236 { first parameter must be an object or class } 237 if tpointerdef(p.resultdef).pointeddef.typ<>objectdef then 238 begin 239 Message(parser_e_pointer_to_class_expected); 240 p.free; 241 new_dispose_statement:=factor(false,[]); 242 consume_all_until(_RKLAMMER); 243 consume(_RKLAMMER); 244 exit; 245 end; 246 { check, if the first parameter is a pointer to a _class_ } 247 classh:=tobjectdef(tpointerdef(p.resultdef).pointeddef); 248 if is_class(classh) then 249 begin 250 Message(parser_e_no_new_or_dispose_for_classes); 251 new_dispose_statement:=factor(false,[]); 252 consume_all_until(_RKLAMMER); 253 consume(_RKLAMMER); 254 exit; 255 end; 256 { search cons-/destructor, also in parent classes } 257 storepos:=current_tokenpos; 258 current_tokenpos:=destructorpos; 259 sym:=search_struct_member(classh,destructorname); 260 current_tokenpos:=storepos; 261 262 { the second parameter of new/dispose must be a call } 263 { to a cons-/destructor } 264 if (not assigned(sym)) or (sym.typ<>procsym) then 265 begin 266 if is_new then 267 Message(parser_e_expr_have_to_be_constructor_call) 268 else 269 Message(parser_e_expr_have_to_be_destructor_call); 270 p.free; 271 new_dispose_statement:=cerrornode.create; 272 end 273 else 274 begin 275 { For new(var,constructor) we need to take a copy because 276 p is also used in the assignmentn below } 277 if is_new then 278 begin 279 p2:=cderefnode.create(p.getcopy); 280 include(p2.flags,nf_no_checkpointer); 281 end 282 else 283 p2:=cderefnode.create(p); 284 do_typecheckpass(p2); 285 if is_new then 286 callflag:=cnf_new_call 287 else 288 callflag:=cnf_dispose_call; 289 if is_new then 290 do_member_read(classh,false,sym,p2,again,[callflag],nil) 291 else 292 begin 293 if not(m_fpc in current_settings.modeswitches) then 294 do_member_read(classh,false,sym,p2,again,[callflag],nil) 295 else 296 begin 297 p2:=ccallnode.create(nil,tprocsym(sym),sym.owner,p2,[callflag],nil); 298 { support dispose(p,done()); } 299 if try_to_consume(_LKLAMMER) then 300 begin 301 if not try_to_consume(_RKLAMMER) then 302 begin 303 Message(parser_e_no_paras_for_destructor); 304 consume_all_until(_RKLAMMER); 305 consume(_RKLAMMER); 306 end; 307 end; 308 end; 309 end; 310 311 { we need the real called method } 312 do_typecheckpass(p2); 313 314 if (p2.nodetype=calln) and 315 assigned(tcallnode(p2).procdefinition) then 316 begin 317 if is_new then 318 begin 319 if (tcallnode(p2).procdefinition.proctypeoption<>potype_constructor) then 320 Message(parser_e_expr_have_to_be_constructor_call); 321 p2.resultdef:=p.resultdef; 322 p2:=cassignmentnode.create(p,p2); 323 end 324 else 325 begin 326 if (tcallnode(p2).procdefinition.proctypeoption<>potype_destructor) then 327 Message(parser_e_expr_have_to_be_destructor_call); 328 end; 329 end 330 else 331 begin 332 if is_new then 333 CGMessage(parser_e_expr_have_to_be_constructor_call) 334 else 335 CGMessage(parser_e_expr_have_to_be_destructor_call); 336 end; 337 338 result:=p2; 339 end; 340 end 341 else 342 begin 343 if (p.resultdef.typ<>pointerdef) then 344 Begin 345 if is_typeparam(p.resultdef) then 346 begin 347 p.free; 348 consume(_RKLAMMER); 349 new_dispose_statement:=cnothingnode.create; 350 exit; 351 end 352 else 353 begin 354 Message1(type_e_pointer_type_expected,p.resultdef.typename); 355 new_dispose_statement:=cerrornode.create; 356 end; 357 end 358 else 359 begin 360 if (tpointerdef(p.resultdef).pointeddef.typ=objectdef) and 361 (oo_has_vmt in tobjectdef(tpointerdef(p.resultdef).pointeddef).objectoptions) then 362 Message(parser_w_use_extended_syntax_for_objects); 363 if (tpointerdef(p.resultdef).pointeddef.typ=orddef) and 364 (torddef(tpointerdef(p.resultdef).pointeddef).ordtype=uvoid) then 365 begin 366 if (m_tp7 in current_settings.modeswitches) or 367 (m_delphi in current_settings.modeswitches) then 368 Message(parser_w_no_new_dispose_on_void_pointers) 369 else 370 Message(parser_e_no_new_dispose_on_void_pointers); 371 end; 372 373 { create statements with call to getmem+initialize or 374 finalize+freemem } 375 new_dispose_statement:=internalstatements(newstatement); 376 377 if is_new then 378 begin 379 { create temp for result } 380 temp := ctempcreatenode.create(p.resultdef,p.resultdef.size,tt_persistent,true); 381 addstatement(newstatement,temp); 382 383 { create call to fpc_getmem } 384 para := ccallparanode.create(cordconstnode.create 385 (tpointerdef(p.resultdef).pointeddef.size,s32inttype,true),nil); 386 addstatement(newstatement,cassignmentnode.create( 387 ctemprefnode.create(temp), 388 ccallnode.createintern('fpc_getmem',para))); 389 390 { create call to fpc_initialize } 391 if is_managed_type(tpointerdef(p.resultdef).pointeddef) or 392 ((m_isolike_io in current_settings.modeswitches) and (tpointerdef(p.resultdef).pointeddef.typ=filedef)) then 393 addstatement(newstatement,cnodeutils.initialize_data_node(cderefnode.create(ctemprefnode.create(temp)),false)); 394 395 { copy the temp to the destination } 396 addstatement(newstatement,cassignmentnode.create( 397 p, 398 ctemprefnode.create(temp))); 399 400 ReadVariantRecordConstants; 401 402 { release temp } 403 addstatement(newstatement,ctempdeletenode.create(temp)); 404 end 405 else 406 begin 407 temp:=nil; 408 { create call to fpc_finalize } 409 if is_managed_type(tpointerdef(p.resultdef).pointeddef) then 410 if might_have_sideeffects(p) then 411 begin 412 { ensure that p gets evaluated only once, in case it is e.g. a call } 413 temp:=ctempcreatenode.create_value(p.resultdef,p.resultdef.size,tt_persistent,true,p); 414 addstatement(newstatement,temp); 415 addstatement(newstatement,cnodeutils.finalize_data_node(cderefnode.create(ctemprefnode.create(temp)))); 416 end 417 else 418 addstatement(newstatement,cnodeutils.finalize_data_node(cderefnode.create(p.getcopy))); 419 420 ReadVariantRecordConstants; 421 422 { create call to fpc_freemem } 423 if not assigned(temp) then 424 para := ccallparanode.create(p,nil) 425 else 426 para := ccallparanode.create(ctemprefnode.create(temp),nil); 427 addstatement(newstatement,ccallnode.createintern('fpc_freemem',para)); 428 if assigned(temp) then 429 addstatement(newstatement,ctempdeletenode.create(temp)); 430 end; 431 end; 432 end; 433 consume(_RKLAMMER); 434 end; 435 436 new_functionnull437 function new_function : tnode; 438 var 439 p1,p2 : tnode; 440 classh : tobjectdef; 441 srsym : tsym; 442 srsymtable : TSymtable; 443 again : boolean; { dummy for do_proc_call } 444 begin 445 if target_info.system in systems_managed_vm then 446 message(parser_e_feature_unsupported_for_vm); 447 consume(_LKLAMMER); 448 p1:=factor(false,[]); 449 if p1.nodetype<>typen then 450 begin 451 Message(type_e_type_id_expected); 452 consume_all_until(_RKLAMMER); 453 consume(_RKLAMMER); 454 p1.destroy; 455 new_function:=cerrornode.create; 456 exit; 457 end; 458 459 if (p1.resultdef.typ<>pointerdef) then 460 begin 461 Message1(type_e_pointer_type_expected,p1.resultdef.typename); 462 consume_all_until(_RKLAMMER); 463 consume(_RKLAMMER); 464 p1.destroy; 465 new_function:=cerrornode.create; 466 exit; 467 end; 468 469 if try_to_consume(_RKLAMMER) then 470 begin 471 if (tpointerdef(p1.resultdef).pointeddef.typ=objectdef) and 472 (oo_has_vmt in tobjectdef(tpointerdef(p1.resultdef).pointeddef).objectoptions) then 473 Message(parser_w_use_extended_syntax_for_objects); 474 475 if p1.nodetype=typen then 476 ttypenode(p1).allowed:=true; 477 478 p1:=cinlinenode.create(in_new_x,false,p1); 479 end 480 else 481 begin 482 consume(_COMMA); 483 if tpointerdef(p1.resultdef).pointeddef.typ<>objectdef then 484 begin 485 Message(parser_e_pointer_to_class_expected); 486 consume_all_until(_RKLAMMER); 487 consume(_RKLAMMER); 488 p1.destroy; 489 new_function:=cerrornode.create; 490 exit; 491 end; 492 classh:=tobjectdef(tpointerdef(p1.resultdef).pointeddef); 493 { use the objectdef for loading the VMT } 494 p2:=p1; 495 p1:=ctypenode.create(tpointerdef(p1.resultdef).pointeddef); 496 do_typecheckpass(p1); 497 { search the constructor also in the symbol tables of 498 the parents } 499 afterassignment:=false; 500 searchsym_in_class(classh,classh,pattern,srsym,srsymtable,[ssf_search_helper]); 501 consume(_ID); 502 do_member_read(classh,false,srsym,p1,again,[cnf_new_call],nil); 503 { we need to know which procedure is called } 504 do_typecheckpass(p1); 505 if not( 506 (p1.nodetype=calln) and 507 assigned(tcallnode(p1).procdefinition) and 508 (tcallnode(p1).procdefinition.proctypeoption=potype_constructor) 509 ) then 510 Message(parser_e_expr_have_to_be_constructor_call); 511 { constructors return boolean, update resultdef to return 512 the pointer to the object } 513 p1.resultdef:=p2.resultdef; 514 p2.free; 515 consume(_RKLAMMER); 516 end; 517 new_function:=p1; 518 end; 519 520 inline_setlengthnull521 function inline_setlength : tnode; 522 var 523 paras: tnode; 524 begin 525 consume(_LKLAMMER); 526 paras:=parse_paras(false,false,_RKLAMMER); 527 consume(_RKLAMMER); 528 if not assigned(paras) then 529 begin 530 result:=cerrornode.create; 531 CGMessage1(parser_e_wrong_parameter_size,'SetLength'); 532 exit; 533 end; 534 result:=cinlinenode.create(in_setlength_x,false,paras); 535 end; 536 537 inline_setstringnull538 function inline_setstring : tnode; 539 var 540 paras, strpara, pcharpara: tnode; 541 procname: string; 542 cp: tstringencoding; 543 begin 544 consume(_LKLAMMER); 545 paras:=parse_paras(false,false,_RKLAMMER); 546 consume(_RKLAMMER); 547 procname:=''; 548 if assigned(paras) and 549 assigned(tcallparanode(paras).right) and 550 assigned(tcallparanode(tcallparanode(paras).right).right) then 551 begin 552 do_typecheckpass(tcallparanode(tcallparanode(paras).right).left); 553 do_typecheckpass(tcallparanode(tcallparanode(tcallparanode(paras).right).right).left); 554 pcharpara:=tcallparanode(tcallparanode(paras).right).left; 555 strpara:=tcallparanode(tcallparanode(tcallparanode(paras).right).right).left; 556 if strpara.resultdef.typ=stringdef then 557 begin 558 { if there are three parameters and the first parameter 559 ( = paras.right.right) is an ansistring, add a codepage 560 parameter } 561 if is_ansistring(strpara.resultdef) then 562 begin 563 cp:=tstringdef(strpara.resultdef).encoding; 564 if (cp=globals.CP_NONE) then 565 cp:=0; 566 paras:=ccallparanode.create(genintconstnode(cp),paras); 567 end; 568 procname:='fpc_setstring_'+tstringdef(strpara.resultdef).stringtypname; 569 { decide which version to call based on the second parameter } 570 if not is_shortstring(strpara.resultdef) then 571 if is_pwidechar(pcharpara.resultdef) or 572 is_widechar(pcharpara.resultdef) or 573 ((pcharpara.resultdef.typ=arraydef) and 574 is_widechar(tarraydef(pcharpara.resultdef).elementdef)) then 575 procname:=procname+'_pwidechar' 576 else 577 procname:=procname+'_pansichar'; 578 end; 579 end; 580 { default version (for error message) in case of missing or wrong 581 parameters } 582 if procname='' then 583 if m_default_unicodestring in current_settings.modeswitches then 584 procname:='fpc_setstring_unicodestr_pwidechar' 585 else if m_default_ansistring in current_settings.modeswitches then 586 procname:='fpc_setstring_ansistr_pansichar' 587 else 588 procname:='fpc_setstring_shortstr'; 589 result:=ccallnode.createintern(procname,paras) 590 end; 591 592 inline_initfinalnull593 function inline_initfinal(isinit: boolean): tnode; 594 var 595 newblock, 596 paras : tnode; 597 npara, 598 destppn, 599 ppn : tcallparanode; 600 begin 601 { for easy exiting if something goes wrong } 602 result := cerrornode.create; 603 604 consume(_LKLAMMER); 605 paras:=parse_paras(false,false,_RKLAMMER); 606 consume(_RKLAMMER); 607 ppn:=tcallparanode(paras); 608 609 if not assigned(paras) or 610 (assigned(ppn.right) and 611 assigned(tcallparanode(ppn.right).right)) then 612 begin 613 if isinit then 614 CGMessage1(parser_e_wrong_parameter_size,'Initialize') 615 else 616 CGMessage1(parser_e_wrong_parameter_size,'Finalize'); 617 exit; 618 end; 619 620 { 2 arguments? } 621 if assigned(ppn.right) then 622 begin 623 destppn:=tcallparanode(ppn.right); 624 { create call to fpc_initialize/finalize_array } 625 npara:=ccallparanode.create(ctypeconvnode.create 626 (ppn.left,s32inttype), 627 ccallparanode.create(caddrnode.create_internal 628 (crttinode.create(tstoreddef(destppn.left.resultdef),initrtti,rdt_normal)), 629 ccallparanode.create(caddrnode.create_internal 630 (destppn.left),nil))); 631 if isinit then 632 newblock:=ccallnode.createintern('fpc_initialize_array',npara) 633 else 634 newblock:=ccallnode.createintern('fpc_finalize_array',npara); 635 destppn.left:=nil; 636 end 637 else 638 begin 639 if isinit then 640 newblock:=cnodeutils.initialize_data_node(ppn.left,true) 641 else 642 newblock:=cnodeutils.finalize_data_node(ppn.left); 643 end; 644 ppn.left:=nil; 645 paras.free; 646 result.free; 647 result:=newblock; 648 end; 649 650 inline_initializenull651 function inline_initialize : tnode; 652 begin 653 result:=inline_initfinal(true); 654 end; 655 656 inline_finalizenull657 function inline_finalize : tnode; 658 begin 659 result:=inline_initfinal(false); 660 end; 661 662 inline_copy_insert_deletenull663 function inline_copy_insert_delete(nr:tinlinenumber;name:string;checkempty:boolean) : tnode; 664 var 665 paras : tnode; 666 { for easy exiting if something goes wrong } 667 begin 668 result := cerrornode.create; 669 670 consume(_LKLAMMER); 671 paras:=parse_paras(false,false,_RKLAMMER); 672 consume(_RKLAMMER); 673 if not assigned(paras) and checkempty then 674 begin 675 CGMessage1(parser_e_wrong_parameter_size,name); 676 exit; 677 end; 678 result.free; 679 result:=cinlinenode.create(nr,false,paras); 680 end; 681 682 inline_copynull683 function inline_copy: tnode; 684 begin 685 result:=inline_copy_insert_delete(in_copy_x,'Copy',false); 686 end; 687 688 inline_insertnull689 function inline_insert: tnode; 690 begin 691 result:=inline_copy_insert_delete(in_insert_x_y_z,'Insert',false); 692 end; 693 694 inline_deletenull695 function inline_delete: tnode; 696 begin 697 result:=inline_copy_insert_delete(in_delete_x_y_z,'Delete',false); 698 end; 699 700 inline_concatnull701 function inline_concat: tnode; 702 begin 703 result:=inline_copy_insert_delete(in_concat_x,'Concat',false); 704 end; 705 706 707 end. 708