1 { 2 Copyright (c) 1998-2002 by Florian Klaempfl 3 4 Compare definitions and parameter lists 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 defcmp; 23 24 {$i fpcdefs.inc} 25 26 interface 27 28 uses 29 cclasses, 30 globtype,globals, 31 node, 32 symconst,symtype,symdef,symbase; 33 34 type 35 { if acp is cp_all the var const or nothing are considered equal } 36 tcompare_paras_type = ( cp_none, cp_value_equal_const, cp_all,cp_procvar); 37 tcompare_paras_option = ( 38 cpo_allowdefaults, 39 cpo_ignorehidden, // ignore hidden parameters 40 cpo_allowconvert, 41 cpo_comparedefaultvalue, 42 cpo_openequalisexact, 43 cpo_ignoreuniv, 44 cpo_warn_incompatible_univ, 45 cpo_ignorevarspez, // ignore parameter access type 46 cpo_ignoreframepointer, // ignore frame pointer parameter (for assignment-compatibility of global procedures to nested procvars) 47 cpo_compilerproc, 48 cpo_rtlproc, 49 cpo_generic // two different undefined defs (or a constraint in the forward) alone or in open arrays are 50 // treated as exactly equal (also in open arrays) if they are owned by their respective procdefs 51 ); 52 53 tcompare_paras_options = set of tcompare_paras_option; 54 55 tcompare_defs_option = ( 56 cdo_internal, 57 cdo_explicit, 58 cdo_check_operator, 59 cdo_allow_variant, 60 cdo_parameter, 61 cdo_warn_incompatible_univ, 62 cdo_strict_undefined_check // undefined defs are incompatible to everything except other undefined defs 63 ); 64 tcompare_defs_options = set of tcompare_defs_option; 65 66 tconverttype = (tc_none, 67 tc_equal, 68 tc_not_possible, 69 tc_string_2_string, 70 tc_char_2_string, 71 tc_char_2_chararray, 72 tc_pchar_2_string, 73 tc_cchar_2_pchar, 74 tc_cstring_2_pchar, 75 tc_cstring_2_int, 76 tc_ansistring_2_pchar, 77 tc_string_2_chararray, 78 tc_chararray_2_string, 79 tc_array_2_pointer, 80 tc_pointer_2_array, 81 tc_int_2_int, 82 tc_int_2_bool, 83 tc_bool_2_bool, 84 tc_bool_2_int, 85 tc_real_2_real, 86 tc_int_2_real, 87 tc_real_2_currency, 88 tc_proc_2_procvar, 89 tc_nil_2_methodprocvar, 90 tc_arrayconstructor_2_set, 91 tc_set_to_set, 92 tc_cord_2_pointer, 93 tc_intf_2_string, 94 tc_intf_2_guid, 95 tc_class_2_intf, 96 tc_char_2_char, 97 tc_dynarray_2_openarray, 98 tc_pwchar_2_string, 99 tc_variant_2_dynarray, 100 tc_dynarray_2_variant, 101 tc_variant_2_enum, 102 tc_enum_2_variant, 103 tc_interface_2_variant, 104 tc_variant_2_interface, 105 tc_array_2_dynarray, 106 tc_elem_2_openarray, 107 tc_arrayconstructor_2_dynarray 108 ); 109 compare_defs_extnull110 function compare_defs_ext(def_from,def_to : tdef; 111 fromtreetype : tnodetype; 112 var doconv : tconverttype; 113 var operatorpd : tprocdef; 114 cdoptions:tcompare_defs_options):tequaltype; 115 116 { Returns if the type def_from can be converted to def_to or if both types are equal } compare_defsnull117 function compare_defs(def_from,def_to:tdef;fromtreetype:tnodetype):tequaltype; 118 119 { Returns true, if def1 and def2 are semantically the same } equal_defsnull120 function equal_defs(def_from,def_to:tdef):boolean; 121 122 { Checks for type compatibility (subgroups of type) 123 used for case statements... probably missing stuff 124 to use on other types } is_subequalnull125 function is_subequal(def1, def2: tdef): boolean; 126 127 {# true, if two parameter lists are equal 128 if acp is cp_all, all have to match exactly 129 if acp is cp_value_equal_const call by value 130 and call by const parameter are assumed as 131 equal 132 if acp is cp_procvar then the varspez have to match, 133 and all parameter types must be at least te_equal 134 if acp is cp_none, then we don't check the varspez at all 135 allowdefaults indicates if default value parameters 136 are allowed (in this case, the search order will first 137 search for a routine with default parameters, before 138 searching for the same definition with no parameters) 139 140 para1 is expected to be parameter list of the first encountered 141 declaration (interface, forward), and para2 that of the second one 142 (important in case of cpo_comparedefaultvalue) 143 } compare_parasnull144 function compare_paras(para1,para2 : TFPObjectList; acp : tcompare_paras_type; cpoptions: tcompare_paras_options):tequaltype; 145 146 { True if a function can be assigned to a procvar } 147 { changed first argument type to pabstractprocdef so that it can also be } 148 { used to test compatibility between two pprocvardefs (JM) } proc_to_procvar_equalnull149 function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef;checkincompatibleuniv: boolean):tequaltype; 150 151 { Parentdef is the definition of a method defined in a parent class or interface } 152 { Childdef is the definition of a method defined in a child class, interface or } 153 { a class implementing an interface with parentdef. } 154 { Returns true if the resultdef of childdef can be used to implement/override } 155 { parentdef's resultdef } compatible_childmethod_resultdefnull156 function compatible_childmethod_resultdef(parentretdef, childretdef: tdef): boolean; 157 158 { Checks whether the class impldef or one of its parent classes implements } 159 { the interface intfdef and returns the corresponding "implementation link } find_implemented_interfacenull160 function find_implemented_interface(impldef,intfdef:tobjectdef):timplementedinterface; 161 162 { Checks whether to defs are related to each other. Thereby the following } 163 { cases of curdef are implemented: } 164 { - stringdef: on JVM JLObject, JLString and AnsiString are compatible } 165 { - recorddef: on JVM records are compatible to java_fpcbaserecordtype } 166 { and JLObject } 167 { - objectdef: if it inherits from otherdef or they are equal } def_is_relatednull168 function def_is_related(curdef,otherdef:tdef):boolean; 169 170 { Checks whether two defs for parameters or result types of a generic } 171 { routine can be considered as equal. Requires the symtables of the } 172 { procdefs the parameters defs shall belong to. } equal_genfunc_paradefsnull173 function equal_genfunc_paradefs(fwdef,currdef:tdef;fwpdst,currpdst:tsymtable):boolean; 174 175 176 implementation 177 178 uses 179 verbose,systems,constexp, 180 symtable,symsym,symcpu, 181 defutil,symutil; 182 183 compare_defs_extnull184 function compare_defs_ext(def_from,def_to : tdef; 185 fromtreetype : tnodetype; 186 var doconv : tconverttype; 187 var operatorpd : tprocdef; 188 cdoptions:tcompare_defs_options):tequaltype; 189 190 { tordtype: 191 uvoid, 192 u8bit,u16bit,u32bit,u64bit, 193 s8bit,s16bit,s32bit,s64bit, 194 pasbool, bool8bit,bool16bit,bool32bit,bool64bit, 195 uchar,uwidechar,scurrency } 196 197 type 198 tbasedef=(bvoid,bchar,bint,bbool); 199 const 200 basedeftbl:array[tordtype] of tbasedef = 201 (bvoid, 202 bint,bint,bint,bint,bint, 203 bint,bint,bint,bint,bint, 204 bbool,bbool,bbool,bbool,bbool, 205 bbool,bbool,bbool,bbool, 206 bchar,bchar,bint); 207 208 basedefconvertsimplicit : array[tbasedef,tbasedef] of tconverttype = 209 { void, char, int, bool } 210 ((tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible), 211 (tc_not_possible,tc_char_2_char,tc_not_possible,tc_not_possible), 212 (tc_not_possible,tc_not_possible,tc_int_2_int,tc_not_possible), 213 (tc_not_possible,tc_not_possible,tc_not_possible,tc_bool_2_bool)); 214 basedefconvertsexplicit : array[tbasedef,tbasedef] of tconverttype = 215 { void, char, int, bool } 216 ((tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible), 217 (tc_not_possible,tc_char_2_char,tc_int_2_int,tc_int_2_bool), 218 (tc_not_possible,tc_int_2_int,tc_int_2_int,tc_int_2_bool), 219 (tc_not_possible,tc_bool_2_int,tc_bool_2_int,tc_bool_2_bool)); 220 221 var 222 subeq,eq : tequaltype; 223 hd1,hd2 : tdef; 224 def_generic : tstoreddef; 225 hct : tconverttype; 226 hobjdef : tobjectdef; 227 hpd : tprocdef; 228 i : longint; 229 diff : boolean; 230 symfrom,symto : tsym; 231 begin 232 eq:=te_incompatible; 233 doconv:=tc_not_possible; 234 235 { safety check } 236 if not(assigned(def_from) and assigned(def_to)) then 237 begin 238 compare_defs_ext:=te_incompatible; 239 exit; 240 end; 241 242 { resolve anonymous external definitions } 243 if def_from.typ=objectdef then 244 def_from:=find_real_class_definition(tobjectdef(def_from),false); 245 if def_to.typ=objectdef then 246 def_to:=find_real_class_definition(tobjectdef(def_to),false); 247 248 { same def? then we've an exact match } 249 if def_from=def_to then 250 begin 251 doconv:=tc_equal; 252 compare_defs_ext:=te_exact; 253 exit; 254 end; 255 256 if cdo_strict_undefined_check in cdoptions then 257 begin 258 { two different undefined defs are not considered equal } 259 if (def_from.typ=undefineddef) and 260 (def_to.typ=undefineddef) then 261 begin 262 doconv:=tc_not_possible; 263 compare_defs_ext:=te_incompatible; 264 exit; 265 end; 266 267 { if only one def is a undefined def then they are not considered as 268 equal} 269 if ( 270 (def_from.typ=undefineddef) or 271 assigned(tstoreddef(def_from).genconstraintdata) 272 ) or ( 273 (def_to.typ=undefineddef) or 274 assigned(tstoreddef(def_to).genconstraintdata) 275 ) then 276 begin 277 doconv:=tc_not_possible; 278 compare_defs_ext:=te_incompatible; 279 exit; 280 end; 281 end 282 else 283 begin 284 { undefined defs are considered equal to everything } 285 if (def_from.typ=undefineddef) or 286 (def_to.typ=undefineddef) then 287 begin 288 doconv:=tc_equal; 289 compare_defs_ext:=te_exact; 290 exit; 291 end; 292 293 { either type has constraints } 294 if assigned(tstoreddef(def_from).genconstraintdata) or 295 assigned(tstoreddef(def_to).genconstraintdata) then 296 begin 297 { constants could get another deftype (e.g. niln) } 298 if (def_from.typ<>def_to.typ) and not(fromtreetype in nodetype_const) then 299 begin 300 { not compatible anyway } 301 doconv:=tc_not_possible; 302 compare_defs_ext:=te_incompatible; 303 exit; 304 end; 305 306 { maybe we are in generic type declaration/implementation. 307 In this case constraint in comparison to not specialized generic 308 is not "exact" nor "incompatible" } 309 if not(((df_genconstraint in def_from.defoptions) and 310 ([df_generic,df_specialization]*def_to.defoptions=[df_generic]) 311 ) or 312 ( 313 (df_genconstraint in def_to.defoptions) and 314 ([df_generic,df_specialization]*def_from.defoptions=[df_generic])) 315 ) then 316 begin 317 { one is definitely a constraint, for the other we don't 318 care right now } 319 doconv:=tc_equal; 320 compare_defs_ext:=te_exact; 321 exit; 322 end; 323 end; 324 end; 325 326 { two specializations are considered equal if they specialize the same 327 generic with the same types } 328 if (df_specialization in def_from.defoptions) and 329 (df_specialization in def_to.defoptions) and 330 (tstoreddef(def_from).genericdef=tstoreddef(def_to).genericdef) then 331 begin 332 if assigned(tstoreddef(def_from).genericparas) xor 333 assigned(tstoreddef(def_to).genericparas) then 334 internalerror(2013030901); 335 diff:=false; 336 if assigned(tstoreddef(def_from).genericparas) then 337 begin 338 if tstoreddef(def_from).genericparas.count<>tstoreddef(def_to).genericparas.count then 339 internalerror(2012091301); 340 for i:=0 to tstoreddef(def_from).genericparas.count-1 do 341 begin 342 if tstoreddef(def_from).genericparas.nameofindex(i)<>tstoreddef(def_to).genericparas.nameofindex(i) then 343 internalerror(2012091302); 344 symfrom:=ttypesym(tstoreddef(def_from).genericparas[i]); 345 symto:=ttypesym(tstoreddef(def_to).genericparas[i]); 346 if not (symfrom.typ=typesym) or not (symto.typ=typesym) then 347 internalerror(2012121401); 348 if not equal_defs(ttypesym(symfrom).typedef,ttypesym(symto).typedef) then 349 diff:=true; 350 if diff then 351 break; 352 end; 353 end; 354 if not diff then 355 begin 356 doconv:=tc_equal; 357 { the definitions are not exactly the same, but only equal } 358 compare_defs_ext:=te_equal; 359 exit; 360 end; 361 end; 362 { handling of partial specializations } 363 if ( 364 (df_generic in def_to.defoptions) and 365 (df_specialization in def_from.defoptions) and 366 (tstoreddef(def_from).genericdef=def_to) 367 ) or ( 368 (df_generic in def_from.defoptions) and 369 (df_specialization in def_to.defoptions) and 370 (tstoreddef(def_to).genericdef=def_from) 371 ) then 372 begin 373 if tstoreddef(def_from).genericdef=def_to then 374 def_generic:=tstoreddef(def_to) 375 else 376 def_generic:=tstoreddef(def_from); 377 if not assigned(def_generic.genericparas) then 378 internalerror(2014052306); 379 diff:=false; 380 for i:=0 to def_generic.genericparas.count-1 do 381 begin 382 symfrom:=tsym(def_generic.genericparas[i]); 383 if symfrom.typ<>typesym then 384 internalerror(2014052307); 385 if ttypesym(symfrom).typedef.typ<>undefineddef then 386 diff:=true; 387 if diff then 388 break; 389 end; 390 if not diff then 391 begin 392 doconv:=tc_equal; 393 { the definitions are not exactly the same, but only equal } 394 compare_defs_ext:=te_equal; 395 exit; 396 end; 397 end; 398 399 { we walk the wanted (def_to) types and check then the def_from 400 types if there is a conversion possible } 401 case def_to.typ of 402 orddef : 403 begin 404 case def_from.typ of 405 orddef : 406 begin 407 if (torddef(def_from).ordtype=torddef(def_to).ordtype) then 408 begin 409 case torddef(def_from).ordtype of 410 uchar,uwidechar, 411 u8bit,u16bit,u32bit,u64bit, 412 s8bit,s16bit,s32bit,s64bit: 413 begin 414 if (torddef(def_from).low>=torddef(def_to).low) and 415 (torddef(def_from).high<=torddef(def_to).high) then 416 eq:=te_equal 417 else 418 begin 419 doconv:=tc_int_2_int; 420 eq:=te_convert_l1; 421 end; 422 end; 423 uvoid, 424 pasbool1,pasbool8,pasbool16,pasbool32,pasbool64, 425 bool8bit,bool16bit,bool32bit,bool64bit: 426 eq:=te_equal; 427 else 428 internalerror(200210061); 429 end; 430 end 431 { currency cannot be implicitly converted to an ordinal 432 type } 433 else if not is_currency(def_from) or 434 (cdo_explicit in cdoptions) then 435 begin 436 if cdo_explicit in cdoptions then 437 doconv:=basedefconvertsexplicit[basedeftbl[torddef(def_from).ordtype],basedeftbl[torddef(def_to).ordtype]] 438 else 439 doconv:=basedefconvertsimplicit[basedeftbl[torddef(def_from).ordtype],basedeftbl[torddef(def_to).ordtype]]; 440 if (doconv=tc_not_possible) then 441 eq:=te_incompatible 442 else if (not is_in_limit(def_from,def_to)) then 443 { "punish" bad type conversions :) (JM) } 444 eq:=te_convert_l3 445 else 446 eq:=te_convert_l1; 447 end; 448 end; 449 enumdef : 450 begin 451 { needed for char(enum) } 452 if cdo_explicit in cdoptions then 453 begin 454 doconv:=tc_int_2_int; 455 eq:=te_convert_l1; 456 end; 457 end; 458 floatdef : 459 begin 460 if is_currency(def_to) then 461 begin 462 doconv:=tc_real_2_currency; 463 eq:=te_convert_l2; 464 end; 465 end; 466 objectdef: 467 begin 468 if (m_delphi in current_settings.modeswitches) and 469 is_implicit_pointer_object_type(def_from) and 470 (cdo_explicit in cdoptions) then 471 begin 472 eq:=te_convert_l1; 473 if (fromtreetype=niln) then 474 begin 475 { will be handled by the constant folding } 476 doconv:=tc_equal; 477 end 478 else 479 doconv:=tc_int_2_int; 480 end; 481 end; 482 classrefdef, 483 procvardef, 484 pointerdef : 485 begin 486 if cdo_explicit in cdoptions then 487 begin 488 eq:=te_convert_l1; 489 if (fromtreetype=niln) then 490 begin 491 { will be handled by the constant folding } 492 doconv:=tc_equal; 493 end 494 else 495 doconv:=tc_int_2_int; 496 end; 497 end; 498 arraydef : 499 begin 500 if (m_mac in current_settings.modeswitches) and 501 is_integer(def_to) and 502 (fromtreetype=stringconstn) then 503 begin 504 eq:=te_convert_l3; 505 doconv:=tc_cstring_2_int; 506 end; 507 end; 508 end; 509 end; 510 511 stringdef : 512 begin 513 case def_from.typ of 514 stringdef : 515 begin 516 { Constant string } 517 if (fromtreetype=stringconstn) and 518 is_shortstring(def_from) and 519 is_shortstring(def_to) then 520 eq:=te_equal 521 else if (tstringdef(def_to).stringtype=st_ansistring) and 522 (tstringdef(def_from).stringtype=st_ansistring) then 523 begin 524 { don't convert ansistrings if any condition is true: 525 1) same encoding 526 2) from explicit codepage ansistring to ansistring and vice versa 527 3) from any ansistring to rawbytestring 528 4) from rawbytestring to any ansistring } 529 if (tstringdef(def_from).encoding=tstringdef(def_to).encoding) or 530 ((tstringdef(def_to).encoding=0) and (tstringdef(def_from).encoding=getansistringcodepage)) or 531 ((tstringdef(def_to).encoding=getansistringcodepage) and (tstringdef(def_from).encoding=0)) or 532 (tstringdef(def_to).encoding=globals.CP_NONE) or 533 (tstringdef(def_from).encoding=globals.CP_NONE) then 534 begin 535 eq:=te_equal; 536 end 537 else 538 begin 539 doconv := tc_string_2_string; 540 541 { prefere conversion to utf8 codepage } 542 if tstringdef(def_to).encoding = globals.CP_UTF8 then 543 eq:=te_convert_l1 544 { else to AnsiString type } 545 else if def_to=getansistringdef then 546 eq:=te_convert_l2 547 { else to AnsiString with other codepage } 548 else 549 eq:=te_convert_l3; 550 end 551 end 552 else 553 { same string type ? } 554 if (tstringdef(def_from).stringtype=tstringdef(def_to).stringtype) and 555 { for shortstrings also the length must match } 556 ((tstringdef(def_from).stringtype<>st_shortstring) or 557 (tstringdef(def_from).len=tstringdef(def_to).len)) and 558 { for ansi- and unicodestrings also the encoding must match } 559 (not(tstringdef(def_from).stringtype in [st_ansistring,st_unicodestring]) or 560 (tstringdef(def_from).encoding=tstringdef(def_to).encoding)) then 561 eq:=te_equal 562 else 563 begin 564 doconv:=tc_string_2_string; 565 case tstringdef(def_from).stringtype of 566 st_widestring : 567 begin 568 case tstringdef(def_to).stringtype of 569 { Prefer conversions to unicodestring } 570 st_unicodestring: eq:=te_convert_l1; 571 { else prefer conversions to ansistring } 572 st_ansistring: eq:=te_convert_l2; 573 else 574 eq:=te_convert_l3; 575 end; 576 end; 577 st_unicodestring : 578 begin 579 case tstringdef(def_to).stringtype of 580 { Prefer conversions to widestring } 581 st_widestring: eq:=te_convert_l1; 582 { else prefer conversions to ansistring } 583 st_ansistring: eq:=te_convert_l2; 584 else 585 eq:=te_convert_l3; 586 end; 587 end; 588 st_shortstring : 589 begin 590 { Prefer shortstrings of different length or conversions 591 from shortstring to ansistring } 592 case tstringdef(def_to).stringtype of 593 st_shortstring: eq:=te_convert_l1; 594 st_ansistring: 595 if tstringdef(def_to).encoding=globals.CP_UTF8 then 596 eq:=te_convert_l2 597 else if def_to=getansistringdef then 598 eq:=te_convert_l3 599 else 600 eq:=te_convert_l4; 601 st_unicodestring: eq:=te_convert_l5; 602 else 603 eq:=te_convert_l6; 604 end; 605 end; 606 st_ansistring : 607 begin 608 { Prefer conversion to widestrings } 609 case tstringdef(def_to).stringtype of 610 st_unicodestring: eq:=te_convert_l4; 611 st_widestring: eq:=te_convert_l5; 612 else 613 eq:=te_convert_l6; 614 end; 615 end; 616 end; 617 end; 618 end; 619 orddef : 620 begin 621 { char to string} 622 if is_char(def_from) then 623 begin 624 doconv:=tc_char_2_string; 625 case tstringdef(def_to).stringtype of 626 st_shortstring: eq:=te_convert_l1; 627 st_ansistring: eq:=te_convert_l2; 628 st_unicodestring: eq:=te_convert_l3; 629 st_widestring: eq:=te_convert_l4; 630 else 631 eq:=te_convert_l5; 632 end; 633 end 634 else 635 if is_widechar(def_from) then 636 begin 637 doconv:=tc_char_2_string; 638 case tstringdef(def_to).stringtype of 639 st_unicodestring: eq:=te_convert_l1; 640 st_widestring: eq:=te_convert_l2; 641 st_ansistring: eq:=te_convert_l3; 642 st_shortstring: eq:=te_convert_l4; 643 else 644 eq:=te_convert_l5; 645 end; 646 end; 647 end; 648 arraydef : 649 begin 650 { array of char to string, the length check is done by the firstpass of this node } 651 if (is_chararray(def_from) or 652 is_open_chararray(def_from)) and 653 { bitpacked arrays of char whose element bitsize is not 654 8 cannot be auto-converted to strings } 655 (not is_packed_array(def_from) or 656 (tarraydef(def_from).elementdef.packedbitsize=8)) then 657 begin 658 { "Untyped" stringconstn is an array of char } 659 if fromtreetype=stringconstn then 660 begin 661 doconv:=tc_string_2_string; 662 { prefered string type depends on the $H switch } 663 if (m_default_unicodestring in current_settings.modeswitches) and 664 (cs_refcountedstrings in current_settings.localswitches) then 665 case tstringdef(def_to).stringtype of 666 st_unicodestring: eq:=te_equal; 667 st_widestring: eq:=te_convert_l1; 668 // widechar: eq:=te_convert_l2; 669 // ansichar: eq:=te_convert_l3; 670 st_ansistring: eq:=te_convert_l4; 671 st_shortstring: eq:=te_convert_l5; 672 else 673 eq:=te_convert_l6; 674 end 675 else if not(cs_refcountedstrings in current_settings.localswitches) and 676 (tstringdef(def_to).stringtype=st_shortstring) then 677 eq:=te_equal 678 else if not(m_default_unicodestring in current_settings.modeswitches) and 679 (cs_refcountedstrings in current_settings.localswitches) and 680 (tstringdef(def_to).stringtype=st_ansistring) then 681 eq:=te_equal 682 else if tstringdef(def_to).stringtype in [st_widestring,st_unicodestring] then 683 eq:=te_convert_l3 684 else 685 eq:=te_convert_l1; 686 end 687 else 688 begin 689 doconv:=tc_chararray_2_string; 690 if is_open_array(def_from) then 691 begin 692 if is_ansistring(def_to) then 693 eq:=te_convert_l1 694 else if is_wide_or_unicode_string(def_to) then 695 eq:=te_convert_l3 696 else 697 eq:=te_convert_l2; 698 end 699 else 700 begin 701 if is_shortstring(def_to) then 702 begin 703 { Only compatible with arrays that fit 704 smaller than 255 chars } 705 if (def_from.size <= 255) then 706 eq:=te_convert_l1; 707 end 708 else if is_ansistring(def_to) then 709 begin 710 if (def_from.size > 255) then 711 eq:=te_convert_l1 712 else 713 eq:=te_convert_l2; 714 end 715 else if is_wide_or_unicode_string(def_to) then 716 eq:=te_convert_l3 717 else 718 eq:=te_convert_l2; 719 end; 720 end; 721 end 722 else 723 { array of widechar to string, the length check is done by the firstpass of this node } 724 if is_widechararray(def_from) or is_open_widechararray(def_from) then 725 begin 726 doconv:=tc_chararray_2_string; 727 if is_wide_or_unicode_string(def_to) then 728 eq:=te_convert_l1 729 else 730 { size of widechar array is double due the sizeof a widechar } 731 if not(is_shortstring(def_to) and (is_open_widechararray(def_from) or (def_from.size>255*sizeof(widechar)))) then 732 eq:=te_convert_l3 733 else 734 eq:=te_convert_l2; 735 end; 736 end; 737 pointerdef : 738 begin 739 { pchar can be assigned to short/ansistrings, 740 but not in tp7 compatible mode } 741 if not(m_tp7 in current_settings.modeswitches) then 742 begin 743 if is_pchar(def_from) then 744 begin 745 doconv:=tc_pchar_2_string; 746 { prefer ansistrings/unicodestrings because pchars 747 can overflow shortstrings; don't use l1/l2/l3 748 because then pchar -> ansistring has the same 749 preference as conststring -> pchar, and this 750 breaks webtbs/tw3328.pp } 751 if is_ansistring(def_to) then 752 eq:=te_convert_l2 753 else if is_wide_or_unicode_string(def_to) then 754 eq:=te_convert_l3 755 else 756 eq:=te_convert_l4 757 end 758 else if is_pwidechar(def_from) then 759 begin 760 doconv:=tc_pwchar_2_string; 761 if is_wide_or_unicode_string(def_to) then 762 eq:=te_convert_l1 763 else 764 { shortstring and ansistring can both result in 765 data loss, so don't prefer one over the other } 766 eq:=te_convert_l3; 767 end; 768 end; 769 end; 770 objectdef : 771 begin 772 { corba interface -> id string } 773 if is_interfacecorba(def_from) then 774 begin 775 doconv:=tc_intf_2_string; 776 eq:=te_convert_l1; 777 end 778 else if (def_from=java_jlstring) then 779 begin 780 if is_wide_or_unicode_string(def_to) then 781 begin 782 doconv:=tc_equal; 783 eq:=te_equal; 784 end 785 else if def_to.typ=stringdef then 786 begin 787 doconv:=tc_string_2_string; 788 if is_ansistring(def_to) then 789 eq:=te_convert_l2 790 else 791 eq:=te_convert_l3 792 end; 793 end; 794 end; 795 end; 796 end; 797 798 floatdef : 799 begin 800 case def_from.typ of 801 orddef : 802 begin { ordinal to real } 803 { only for implicit and internal typecasts in tp/delphi } 804 if (([cdo_explicit,cdo_internal] * cdoptions <> [cdo_explicit]) or 805 ([m_tp7,m_delphi] * current_settings.modeswitches = [])) and 806 (is_integer(def_from) or 807 (is_currency(def_from) and 808 (s64currencytype.typ = floatdef))) then 809 begin 810 doconv:=tc_int_2_real; 811 812 { prefer single over others } 813 if is_single(def_to) then 814 eq:=te_convert_l3 815 else 816 eq:=te_convert_l4; 817 end 818 else if is_currency(def_from) 819 { and (s64currencytype.typ = orddef)) } then 820 begin 821 { prefer conversion to orddef in this case, unless } 822 { the orddef < currency (then it will get convert l3, } 823 { and conversion to float is favoured) } 824 doconv:=tc_int_2_real; 825 if is_extended(def_to) then 826 eq:=te_convert_l2 827 else if is_double(def_to) then 828 eq:=te_convert_l3 829 else if is_single(def_to) then 830 eq:=te_convert_l4 831 else 832 eq:=te_convert_l2; 833 end; 834 end; 835 floatdef : 836 begin 837 if tfloatdef(def_from).floattype=tfloatdef(def_to).floattype then 838 eq:=te_equal 839 else 840 begin 841 { Delphi does not allow explicit type conversions for float types like: 842 single_var:=single(double_var); 843 But if such conversion is inserted by compiler (internal) for some purpose, 844 it should be allowed even in Delphi mode. } 845 if (fromtreetype=realconstn) or 846 not((cdoptions*[cdo_explicit,cdo_internal]=[cdo_explicit]) and 847 (m_delphi in current_settings.modeswitches)) then 848 begin 849 doconv:=tc_real_2_real; 850 { do we lose precision? } 851 if (def_to.size<def_from.size) or 852 (is_currency(def_from) and (tfloatdef(def_to).floattype in [s32real,s64real])) then 853 begin 854 if is_currency(def_from) and (tfloatdef(def_to).floattype=s32real) then 855 eq:=te_convert_l3 856 else 857 eq:=te_convert_l2 858 end 859 else 860 eq:=te_convert_l1; 861 end; 862 end; 863 end; 864 end; 865 end; 866 867 enumdef : 868 begin 869 case def_from.typ of 870 enumdef : 871 begin 872 if cdo_explicit in cdoptions then 873 begin 874 eq:=te_convert_l1; 875 doconv:=tc_int_2_int; 876 end 877 else 878 begin 879 hd1:=def_from; 880 while assigned(tenumdef(hd1).basedef) do 881 hd1:=tenumdef(hd1).basedef; 882 hd2:=def_to; 883 while assigned(tenumdef(hd2).basedef) do 884 hd2:=tenumdef(hd2).basedef; 885 if (hd1=hd2) then 886 begin 887 eq:=te_convert_l1; 888 { because of packenum they can have different sizes! (JM) } 889 doconv:=tc_int_2_int; 890 end 891 else 892 begin 893 { assignment of an enum symbol to an unique type? } 894 if (fromtreetype=ordconstn) and 895 (tenumsym(tenumdef(hd1).getfirstsym)=tenumsym(tenumdef(hd2).getfirstsym)) then 896 begin 897 { because of packenum they can have different sizes! (JM) } 898 eq:=te_convert_l1; 899 doconv:=tc_int_2_int; 900 end; 901 end; 902 end; 903 end; 904 orddef : 905 begin 906 if cdo_explicit in cdoptions then 907 begin 908 eq:=te_convert_l1; 909 doconv:=tc_int_2_int; 910 end; 911 end; 912 variantdef : 913 begin 914 eq:=te_convert_l1; 915 doconv:=tc_variant_2_enum; 916 end; 917 pointerdef : 918 begin 919 { ugly, but delphi allows it } 920 if cdo_explicit in cdoptions then 921 begin 922 if target_info.system in systems_jvm then 923 begin 924 doconv:=tc_equal; 925 eq:=te_convert_l1; 926 end 927 else if m_delphi in current_settings.modeswitches then 928 begin 929 doconv:=tc_int_2_int; 930 eq:=te_convert_l1; 931 end 932 end; 933 end; 934 objectdef: 935 begin 936 { ugly, but delphi allows it } 937 if (cdo_explicit in cdoptions) and 938 is_class_or_interface_or_dispinterface_or_objc_or_java(def_from) then 939 begin 940 { in Java enums /are/ class instances, and hence such 941 typecasts must not be treated as integer-like 942 conversions 943 } 944 if target_info.system in systems_jvm then 945 begin 946 doconv:=tc_equal; 947 eq:=te_convert_l1; 948 end 949 else if m_delphi in current_settings.modeswitches then 950 begin 951 doconv:=tc_int_2_int; 952 eq:=te_convert_l1; 953 end; 954 end; 955 end; 956 end; 957 end; 958 959 arraydef : 960 begin 961 { open array is also compatible with a single element of its base type. 962 the extra check for deftyp is needed because equal defs can also return 963 true if the def types are not the same, for example with dynarray to pointer. } 964 if is_open_array(def_to) and 965 (def_from.typ=tarraydef(def_to).elementdef.typ) and 966 equal_defs(def_from,tarraydef(def_to).elementdef) then 967 begin 968 doconv:=tc_elem_2_openarray; 969 { also update in htypechk.pas/var_para_allowed if changed 970 here } 971 eq:=te_convert_l3; 972 end 973 else 974 begin 975 case def_from.typ of 976 arraydef : 977 begin 978 { from/to packed array -- packed chararrays are } 979 { strings in ISO Pascal (at least if the lower bound } 980 { is 1, but GPC makes all equal-length chararrays } 981 { compatible), so treat those the same as regular } 982 { char arrays -- except if they use subrange types } 983 if (is_packed_array(def_from) and 984 (not is_chararray(def_from) or 985 (tarraydef(def_from).elementdef.packedbitsize<>8)) and 986 not is_widechararray(def_from)) xor 987 (is_packed_array(def_to) and 988 (not is_chararray(def_to) or 989 (tarraydef(def_to).elementdef.packedbitsize<>8)) and 990 not is_widechararray(def_to)) then 991 { both must be packed } 992 begin 993 compare_defs_ext:=te_incompatible; 994 exit; 995 end 996 { to dynamic array } 997 else if is_dynamic_array(def_to) then 998 begin 999 if is_array_constructor(def_from) then 1000 begin 1001 { array constructor -> dynamic array } 1002 if is_void(tarraydef(def_from).elementdef) then 1003 begin 1004 { only needs to loose to [] -> open array } 1005 eq:=te_convert_l2; 1006 doconv:=tc_arrayconstructor_2_dynarray; 1007 end 1008 else 1009 begin 1010 { this should loose to the array constructor -> open array conversions, 1011 but it might happen that the end of the convert levels is reached :/ } 1012 subeq:=compare_defs_ext(tarraydef(def_from).elementdef, 1013 tarraydef(def_to).elementdef, 1014 { reason for cdo_allow_variant: see webtbs/tw7070a and webtbs/tw7070b } 1015 arrayconstructorn,hct,hpd,[cdo_check_operator,cdo_allow_variant]); 1016 if (subeq>=te_equal) then 1017 begin 1018 eq:=te_convert_l2; 1019 end 1020 else 1021 { an array constructor is not a dynamic array, so 1022 use a lower level of compatibility than that one of 1023 of the elements } 1024 if subeq>te_convert_l5 then 1025 begin 1026 eq:=pred(pred(subeq)); 1027 end 1028 else if subeq>te_convert_l6 then 1029 eq:=pred(subeq) 1030 else if subeq=te_convert_operator then 1031 { the operater needs to be applied by element, so we tell 1032 the caller that it's some unpreffered conversion and let 1033 it handle the per-element stuff } 1034 eq:=te_convert_l6 1035 else 1036 eq:=subeq; 1037 doconv:=tc_arrayconstructor_2_dynarray; 1038 end; 1039 end 1040 else if equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) then 1041 begin 1042 { dynamic array -> dynamic array } 1043 if is_dynamic_array(def_from) then 1044 eq:=te_equal 1045 { fpc modes only: array -> dyn. array } 1046 else if (current_settings.modeswitches*[m_objfpc,m_fpc]<>[]) and 1047 not(is_special_array(def_from)) and 1048 is_zero_based_array(def_from) then 1049 begin 1050 eq:=te_convert_l2; 1051 doconv:=tc_array_2_dynarray; 1052 end; 1053 end 1054 end 1055 else 1056 { to open array } 1057 if is_open_array(def_to) then 1058 begin 1059 { array constructor -> open array } 1060 if is_array_constructor(def_from) then 1061 begin 1062 if is_void(tarraydef(def_from).elementdef) then 1063 begin 1064 doconv:=tc_equal; 1065 eq:=te_convert_l1; 1066 end 1067 else 1068 begin 1069 subeq:=compare_defs_ext(tarraydef(def_from).elementdef, 1070 tarraydef(def_to).elementdef, 1071 { reason for cdo_allow_variant: see webtbs/tw7070a and webtbs/tw7070b } 1072 arrayconstructorn,hct,hpd,[cdo_check_operator,cdo_allow_variant]); 1073 if (subeq>=te_equal) then 1074 begin 1075 doconv:=tc_equal; 1076 eq:=te_convert_l1; 1077 end 1078 else 1079 { an array constructor is not an open array, so 1080 use a lower level of compatibility than that one of 1081 of the elements } 1082 if subeq>te_convert_l6 then 1083 begin 1084 doconv:=hct; 1085 eq:=pred(subeq); 1086 end 1087 else 1088 eq:=subeq; 1089 end; 1090 end 1091 else 1092 { dynamic array -> open array } 1093 if is_dynamic_array(def_from) and 1094 equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) then 1095 begin 1096 doconv:=tc_dynarray_2_openarray; 1097 eq:=te_convert_l2; 1098 end 1099 else 1100 { open array -> open array } 1101 if is_open_array(def_from) and 1102 equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) then 1103 if tarraydef(def_from).elementdef=tarraydef(def_to).elementdef then 1104 eq:=te_exact 1105 else 1106 eq:=te_equal 1107 else 1108 { array -> open array } 1109 if not(cdo_parameter in cdoptions) and 1110 equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) then 1111 begin 1112 if fromtreetype=stringconstn then 1113 eq:=te_convert_l1 1114 else 1115 eq:=te_equal; 1116 end; 1117 end 1118 else 1119 { to array of const } 1120 if is_array_of_const(def_to) then 1121 begin 1122 if is_array_of_const(def_from) or 1123 is_array_constructor(def_from) then 1124 begin 1125 eq:=te_equal; 1126 end 1127 else 1128 { array of tvarrec -> array of const } 1129 if equal_defs(tarraydef(def_to).elementdef,tarraydef(def_from).elementdef) then 1130 begin 1131 doconv:=tc_equal; 1132 eq:=te_convert_l1; 1133 end; 1134 end 1135 else 1136 { to array of char, from "Untyped" stringconstn (array of char) } 1137 if (fromtreetype=stringconstn) and 1138 ((is_chararray(def_to) and 1139 { bitpacked arrays of char whose element bitsize is not 1140 8 cannot be auto-converted from strings } 1141 (not is_packed_array(def_to) or 1142 (tarraydef(def_to).elementdef.packedbitsize=8))) or 1143 is_widechararray(def_to)) then 1144 begin 1145 eq:=te_convert_l1; 1146 doconv:=tc_string_2_chararray; 1147 end 1148 else 1149 { other arrays } 1150 begin 1151 { open array -> array } 1152 if not(cdo_parameter in cdoptions) and 1153 is_open_array(def_from) and 1154 equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) then 1155 begin 1156 eq:=te_equal 1157 end 1158 else 1159 { array -> array } 1160 if not(m_tp7 in current_settings.modeswitches) and 1161 not(m_delphi in current_settings.modeswitches) and 1162 (tarraydef(def_from).lowrange=tarraydef(def_to).lowrange) and 1163 (tarraydef(def_from).highrange=tarraydef(def_to).highrange) and 1164 equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) and 1165 equal_defs(tarraydef(def_from).rangedef,tarraydef(def_to).rangedef) then 1166 begin 1167 eq:=te_equal 1168 end; 1169 end; 1170 end; 1171 pointerdef : 1172 begin 1173 { nil and voidpointers are compatible with dyn. arrays } 1174 if is_dynamic_array(def_to) and 1175 ((fromtreetype=niln) or 1176 is_voidpointer(def_from)) then 1177 begin 1178 doconv:=tc_equal; 1179 eq:=te_convert_l1; 1180 end 1181 else 1182 if is_zero_based_array(def_to) and 1183 equal_defs(tpointerdef(def_from).pointeddef,tarraydef(def_to).elementdef) then 1184 begin 1185 doconv:=tc_pointer_2_array; 1186 eq:=te_convert_l1; 1187 end; 1188 end; 1189 stringdef : 1190 begin 1191 { string to char array } 1192 if not is_special_array(def_to) and 1193 ((is_char(tarraydef(def_to).elementdef) and 1194 { bitpacked arrays of char whose element bitsize is not 1195 8 cannot be auto-converted from strings } 1196 (not is_packed_array(def_to) or 1197 (tarraydef(def_to).elementdef.packedbitsize=8))) or 1198 is_widechar(tarraydef(def_to).elementdef)) then 1199 begin 1200 doconv:=tc_string_2_chararray; 1201 eq:=te_convert_l1; 1202 end; 1203 end; 1204 orddef: 1205 begin 1206 if is_chararray(def_to) and 1207 is_char(def_from) then 1208 begin 1209 doconv:=tc_char_2_chararray; 1210 eq:=te_convert_l2; 1211 end; 1212 end; 1213 recorddef : 1214 begin 1215 { tvarrec -> array of const } 1216 if is_array_of_const(def_to) and 1217 equal_defs(def_from,tarraydef(def_to).elementdef) then 1218 begin 1219 doconv:=tc_equal; 1220 eq:=te_convert_l1; 1221 end; 1222 end; 1223 variantdef : 1224 begin 1225 if is_dynamic_array(def_to) then 1226 begin 1227 doconv:=tc_variant_2_dynarray; 1228 eq:=te_convert_l1; 1229 end; 1230 end; 1231 end; 1232 end; 1233 end; 1234 1235 variantdef : 1236 begin 1237 if (cdo_allow_variant in cdoptions) then 1238 begin 1239 case def_from.typ of 1240 enumdef : 1241 begin 1242 doconv:=tc_enum_2_variant; 1243 eq:=te_convert_l1; 1244 end; 1245 arraydef : 1246 begin 1247 if is_dynamic_array(def_from) then 1248 begin 1249 doconv:=tc_dynarray_2_variant; 1250 eq:=te_convert_l1; 1251 end; 1252 end; 1253 objectdef : 1254 begin 1255 { corbainterfaces not accepted, until we have 1256 runtime support for them in Variants (sergei) } 1257 if is_interfacecom_or_dispinterface(def_from) then 1258 begin 1259 doconv:=tc_interface_2_variant; 1260 eq:=te_convert_l1; 1261 end; 1262 end; 1263 variantdef : 1264 begin 1265 { doing this in the compiler avoids a lot of unncessary 1266 copying } 1267 if (tvariantdef(def_from).varianttype=vt_olevariant) and 1268 (tvariantdef(def_to).varianttype=vt_normalvariant) then 1269 begin 1270 doconv:=tc_equal; 1271 eq:=te_convert_l1; 1272 end; 1273 end; 1274 end; 1275 end; 1276 end; 1277 1278 pointerdef : 1279 begin 1280 case def_from.typ of 1281 stringdef : 1282 begin 1283 { string constant (which can be part of array constructor) 1284 to zero terminated string constant } 1285 if (fromtreetype = stringconstn) and 1286 (is_pchar(def_to) or is_pwidechar(def_to)) then 1287 begin 1288 doconv:=tc_cstring_2_pchar; 1289 if is_pwidechar(def_to)=(m_default_unicodestring in current_settings.modeswitches) then 1290 eq:=te_convert_l2 1291 else 1292 eq:=te_convert_l3 1293 end 1294 else 1295 if (cdo_explicit in cdoptions) or (fromtreetype = arrayconstructorn) then 1296 begin 1297 { pchar(ansistring) } 1298 if is_pchar(def_to) and 1299 is_ansistring(def_from) then 1300 begin 1301 doconv:=tc_ansistring_2_pchar; 1302 eq:=te_convert_l1; 1303 end 1304 else 1305 { pwidechar(widestring) } 1306 if is_pwidechar(def_to) and 1307 is_wide_or_unicode_string(def_from) then 1308 begin 1309 doconv:=tc_ansistring_2_pchar; 1310 eq:=te_convert_l1; 1311 end; 1312 end; 1313 end; 1314 orddef : 1315 begin 1316 { char constant to zero terminated string constant } 1317 if (fromtreetype in [ordconstn,arrayconstructorn]) then 1318 begin 1319 if (is_char(def_from) or is_widechar(def_from)) and 1320 (is_pchar(def_to) or is_pwidechar(def_to)) then 1321 begin 1322 doconv:=tc_cchar_2_pchar; 1323 if is_pwidechar(def_to)=(m_default_unicodestring in current_settings.modeswitches) then 1324 eq:=te_convert_l1 1325 else 1326 eq:=te_convert_l2 1327 end 1328 else 1329 if (m_delphi in current_settings.modeswitches) and is_integer(def_from) then 1330 begin 1331 doconv:=tc_cord_2_pointer; 1332 eq:=te_convert_l5; 1333 end; 1334 end; 1335 { allow explicit typecasts from ordinals to pointer. 1336 Support for delphi compatibility 1337 Support constructs like pointer(cardinal-cardinal) or pointer(longint+cardinal) where 1338 the result of the ordinal operation is int64 also on 32 bit platforms. 1339 It is also used by the compiler internally for inc(pointer,ordinal) } 1340 if (eq=te_incompatible) and 1341 not is_void(def_from) and 1342 ( 1343 ( 1344 (cdo_explicit in cdoptions) and 1345 ( 1346 (m_delphi in current_settings.modeswitches) or 1347 { Don't allow pchar(char) in fpc modes } 1348 is_integer(def_from) 1349 ) 1350 ) or 1351 (cdo_internal in cdoptions) 1352 ) then 1353 begin 1354 doconv:=tc_int_2_int; 1355 eq:=te_convert_l1; 1356 end; 1357 end; 1358 enumdef : 1359 begin 1360 { allow explicit typecasts from enums to pointer. 1361 Support for delphi compatibility 1362 } 1363 { in Java enums /are/ class instances, and hence such 1364 typecasts must not be treated as integer-like conversions 1365 } 1366 if (((cdo_explicit in cdoptions) and 1367 ((m_delphi in current_settings.modeswitches) or 1368 (target_info.system in systems_jvm) 1369 ) 1370 ) or 1371 (cdo_internal in cdoptions) 1372 ) then 1373 begin 1374 { in Java enums /are/ class instances, and hence such 1375 typecasts must not be treated as integer-like 1376 conversions 1377 } 1378 if target_info.system in systems_jvm then 1379 begin 1380 doconv:=tc_equal; 1381 eq:=te_convert_l1; 1382 end 1383 else if m_delphi in current_settings.modeswitches then 1384 begin 1385 doconv:=tc_int_2_int; 1386 eq:=te_convert_l1; 1387 end; 1388 end; 1389 end; 1390 arraydef : 1391 begin 1392 { string constant (which can be part of array constructor) 1393 to zero terminated string constant } 1394 if (((fromtreetype = arrayconstructorn) and 1395 { can't use is_chararray, because returns false for } 1396 { array constructors } 1397 is_char(tarraydef(def_from).elementdef)) or 1398 (fromtreetype = stringconstn)) and 1399 (is_pchar(def_to) or is_pwidechar(def_to)) then 1400 begin 1401 doconv:=tc_cstring_2_pchar; 1402 if ((m_default_unicodestring in current_settings.modeswitches) xor 1403 is_pchar(def_to)) then 1404 eq:=te_convert_l2 1405 else 1406 eq:=te_convert_l3; 1407 end 1408 else 1409 { chararray to pointer } 1410 if (is_zero_based_array(def_from) or 1411 is_open_array(def_from)) and 1412 equal_defs(tarraydef(def_from).elementdef,tpointerdef(def_to).pointeddef) then 1413 begin 1414 doconv:=tc_array_2_pointer; 1415 { don't prefer the pchar overload when a constant 1416 string was passed } 1417 if fromtreetype=stringconstn then 1418 eq:=te_convert_l2 1419 else 1420 eq:=te_convert_l1; 1421 end 1422 else 1423 { dynamic array to pointer, delphi only } 1424 if (m_delphi in current_settings.modeswitches) and 1425 is_dynamic_array(def_from) and 1426 is_voidpointer(def_to) then 1427 begin 1428 eq:=te_equal; 1429 end; 1430 end; 1431 pointerdef : 1432 begin 1433 { check for far pointers } 1434 if not tpointerdef(def_from).compatible_with_pointerdef_size(tpointerdef(def_to)) then 1435 begin 1436 if fromtreetype=niln then 1437 eq:=te_equal 1438 else 1439 eq:=te_incompatible; 1440 end 1441 { the types can be forward type, handle before normal type check !! } 1442 else 1443 if assigned(def_to.typesym) and 1444 ((tpointerdef(def_to).pointeddef.typ=forwarddef) or 1445 (tpointerdef(def_from).pointeddef.typ=forwarddef)) then 1446 begin 1447 if (def_from.typesym=def_to.typesym) or 1448 (fromtreetype=niln) then 1449 eq:=te_equal 1450 end 1451 else 1452 { same types } 1453 if equal_defs(tpointerdef(def_from).pointeddef,tpointerdef(def_to).pointeddef) then 1454 begin 1455 eq:=te_equal 1456 end 1457 else 1458 { child class pointer can be assigned to anchestor pointers } 1459 if ( 1460 (tpointerdef(def_from).pointeddef.typ=objectdef) and 1461 (tpointerdef(def_to).pointeddef.typ=objectdef) and 1462 def_is_related(tobjectdef(tpointerdef(def_from).pointeddef), 1463 tobjectdef(tpointerdef(def_to).pointeddef)) 1464 ) then 1465 begin 1466 doconv:=tc_equal; 1467 eq:=te_convert_l1; 1468 end 1469 else 1470 { all pointers can be assigned to void-pointer } 1471 if is_void(tpointerdef(def_to).pointeddef) then 1472 begin 1473 doconv:=tc_equal; 1474 { give pwidechar,pchar a penalty so it prefers 1475 conversion to ansistring } 1476 if is_pchar(def_from) or 1477 is_pwidechar(def_from) then 1478 eq:=te_convert_l2 1479 else 1480 eq:=te_convert_l1; 1481 end 1482 else 1483 { all pointers can be assigned from void-pointer } 1484 if is_void(tpointerdef(def_from).pointeddef) or 1485 { all pointers can be assigned from void-pointer or formaldef pointer, check 1486 tw3777.pp if you change this } 1487 (tpointerdef(def_from).pointeddef.typ=formaldef) then 1488 begin 1489 doconv:=tc_equal; 1490 { give pwidechar a penalty so it prefers 1491 conversion to pchar } 1492 if is_pwidechar(def_to) then 1493 eq:=te_convert_l2 1494 else 1495 eq:=te_convert_l1; 1496 end 1497 { id = generic class instance. metaclasses are also 1498 class instances themselves. } 1499 else if ((def_from=objc_idtype) and 1500 (def_to=objc_metaclasstype)) or 1501 ((def_to=objc_idtype) and 1502 (def_from=objc_metaclasstype)) then 1503 begin 1504 doconv:=tc_equal; 1505 eq:=te_convert_l2; 1506 end; 1507 end; 1508 procvardef : 1509 begin 1510 { procedure variable can be assigned to an void pointer, 1511 this is not allowed for complex procvars } 1512 if (is_void(tpointerdef(def_to).pointeddef) or 1513 (m_mac_procvar in current_settings.modeswitches)) and 1514 tprocvardef(def_from).compatible_with_pointerdef_size(tpointerdef(def_to)) then 1515 begin 1516 doconv:=tc_equal; 1517 eq:=te_convert_l1; 1518 end; 1519 end; 1520 procdef : 1521 begin 1522 { procedure variable can be assigned to an void pointer, 1523 this not allowed for methodpointers } 1524 if (m_mac_procvar in current_settings.modeswitches) and 1525 tprocdef(def_from).compatible_with_pointerdef_size(tpointerdef(def_to)) then 1526 begin 1527 doconv:=tc_proc_2_procvar; 1528 eq:=te_convert_l2; 1529 end; 1530 end; 1531 classrefdef, 1532 objectdef : 1533 begin 1534 { implicit pointer object and class reference types 1535 can be assigned to void pointers, but it is less 1536 preferred than assigning to a related objectdef } 1537 if ( 1538 is_implicit_pointer_object_type(def_from) or 1539 (def_from.typ=classrefdef) 1540 ) and 1541 (tpointerdef(def_to).pointeddef.typ=orddef) and 1542 (torddef(tpointerdef(def_to).pointeddef).ordtype=uvoid) then 1543 begin 1544 doconv:=tc_equal; 1545 eq:=te_convert_l2; 1546 end 1547 else if (is_objc_class_or_protocol(def_from) and 1548 (def_to=objc_idtype)) or 1549 { classrefs are also instances in Objective-C, 1550 hence they're also assignment-cpmpatible with 1551 id } 1552 (is_objcclassref(def_from) and 1553 ((def_to=objc_metaclasstype) or 1554 (def_to=objc_idtype))) then 1555 begin 1556 doconv:=tc_equal; 1557 eq:=te_convert_l2; 1558 end; 1559 end; 1560 end; 1561 end; 1562 1563 setdef : 1564 begin 1565 case def_from.typ of 1566 setdef : 1567 begin 1568 if assigned(tsetdef(def_from).elementdef) and 1569 assigned(tsetdef(def_to).elementdef) then 1570 begin 1571 { sets with the same size (packset setting), element 1572 base type and the same range are equal } 1573 if equal_defs(tsetdef(def_from).elementdef,tsetdef(def_to).elementdef) and 1574 (tsetdef(def_from).setbase=tsetdef(def_to).setbase) and 1575 (tsetdef(def_from).setmax=tsetdef(def_to).setmax) and 1576 (def_from.size=def_to.size) then 1577 eq:=te_equal 1578 else if is_subequal(tsetdef(def_from).elementdef,tsetdef(def_to).elementdef) then 1579 begin 1580 eq:=te_convert_l1; 1581 doconv:=tc_set_to_set; 1582 end; 1583 end 1584 else 1585 begin 1586 { empty set is compatible with everything } 1587 eq:=te_convert_l1; 1588 doconv:=tc_set_to_set; 1589 end; 1590 end; 1591 arraydef : 1592 begin 1593 { automatic arrayconstructor -> set conversion } 1594 if is_array_constructor(def_from) then 1595 begin 1596 doconv:=tc_arrayconstructor_2_set; 1597 eq:=te_convert_l1; 1598 end; 1599 end; 1600 end; 1601 end; 1602 1603 procvardef : 1604 begin 1605 case def_from.typ of 1606 procdef : 1607 begin 1608 { proc -> procvar } 1609 if (m_tp_procvar in current_settings.modeswitches) or 1610 (m_mac_procvar in current_settings.modeswitches) then 1611 begin 1612 subeq:=proc_to_procvar_equal(tprocdef(def_from),tprocvardef(def_to),cdo_warn_incompatible_univ in cdoptions); 1613 if subeq>te_incompatible then 1614 begin 1615 doconv:=tc_proc_2_procvar; 1616 if subeq>te_convert_l5 then 1617 eq:=pred(subeq) 1618 else 1619 eq:=subeq; 1620 end; 1621 end; 1622 end; 1623 procvardef : 1624 begin 1625 { procvar -> procvar } 1626 eq:=proc_to_procvar_equal(tprocvardef(def_from),tprocvardef(def_to),cdo_warn_incompatible_univ in cdoptions); 1627 if eq<te_equal then 1628 doconv:=tc_proc_2_procvar 1629 else 1630 doconv:=tc_equal; 1631 end; 1632 pointerdef : 1633 begin 1634 { nil is compatible with procvars } 1635 if (fromtreetype=niln) then 1636 begin 1637 if not Tprocvardef(def_to).is_addressonly then 1638 {Nil to method pointers requires to convert a single 1639 pointer nil value to a two pointer procvardef.} 1640 doconv:=tc_nil_2_methodprocvar 1641 else 1642 doconv:=tc_equal; 1643 eq:=te_convert_l1; 1644 end 1645 else 1646 { for example delphi allows the assignement from pointers } 1647 { to procedure variables } 1648 if (m_pointer_2_procedure in current_settings.modeswitches) and 1649 is_void(tpointerdef(def_from).pointeddef) and 1650 tprocvardef(def_to).is_addressonly then 1651 begin 1652 doconv:=tc_equal; 1653 eq:=te_convert_l1; 1654 end; 1655 end; 1656 end; 1657 end; 1658 1659 objectdef : 1660 begin 1661 { object pascal objects } 1662 if (def_from.typ=objectdef) and 1663 (def_is_related(tobjectdef(def_from),tobjectdef(def_to))) then 1664 begin 1665 doconv:=tc_equal; 1666 { also update in htypechk.pas/var_para_allowed if changed 1667 here } 1668 eq:=te_convert_l3; 1669 end 1670 { string -> java.lang.string } 1671 else if (def_to=java_jlstring) and 1672 ((def_from.typ=stringdef) or 1673 (fromtreetype=stringconstn)) then 1674 begin 1675 if is_wide_or_unicode_string(def_from) or 1676 ((fromtreetype=stringconstn) and 1677 (cs_refcountedstrings in current_settings.localswitches) and 1678 (m_default_unicodestring in current_settings.modeswitches)) then 1679 begin 1680 doconv:=tc_equal; 1681 eq:=te_equal 1682 end 1683 else 1684 begin 1685 doconv:=tc_string_2_string; 1686 eq:=te_convert_l2; 1687 end; 1688 end 1689 else if (def_to=java_jlstring) and 1690 is_anychar(def_from) then 1691 begin 1692 doconv:=tc_char_2_string; 1693 eq:=te_convert_l2 1694 end 1695 else 1696 { specific to implicit pointer object types } 1697 if is_implicit_pointer_object_type(def_to) then 1698 begin 1699 { void pointer also for delphi mode } 1700 if (m_delphi in current_settings.modeswitches) and 1701 is_voidpointer(def_from) then 1702 begin 1703 doconv:=tc_equal; 1704 { prefer pointer-pointer assignments } 1705 eq:=te_convert_l2; 1706 end 1707 else 1708 { nil is compatible with class instances and interfaces } 1709 if (fromtreetype=niln) then 1710 begin 1711 doconv:=tc_equal; 1712 eq:=te_convert_l1; 1713 end 1714 { All Objective-C classes are compatible with ID } 1715 else if is_objc_class_or_protocol(def_to) and 1716 (def_from=objc_idtype) then 1717 begin 1718 doconv:=tc_equal; 1719 eq:=te_convert_l2; 1720 end 1721 { classes can be assigned to interfaces 1722 (same with objcclass and objcprotocol) } 1723 else if ((is_interface(def_to) and 1724 is_class(def_from)) or 1725 (is_objcprotocol(def_to) and 1726 is_objcclass(def_from)) or 1727 (is_javainterface(def_to) and 1728 is_javaclass(def_from))) and 1729 assigned(tobjectdef(def_from).ImplementedInterfaces) then 1730 begin 1731 { we've to search in parent classes as well } 1732 hobjdef:=tobjectdef(def_from); 1733 while assigned(hobjdef) do 1734 begin 1735 if find_implemented_interface(hobjdef,tobjectdef(def_to))<>nil then 1736 begin 1737 if is_interface(def_to) then 1738 doconv:=tc_class_2_intf 1739 else 1740 { for Objective-C, we don't have to do anything special } 1741 doconv:=tc_equal; 1742 { don't prefer this over objectdef->objectdef } 1743 eq:=te_convert_l2; 1744 break; 1745 end; 1746 hobjdef:=hobjdef.childof; 1747 end; 1748 end 1749 { Interface 2 GUID handling } 1750 else if (def_to=tdef(rec_tguid)) and 1751 (fromtreetype=typen) and 1752 is_interface(def_from) and 1753 assigned(tobjectdef(def_from).iidguid) then 1754 begin 1755 eq:=te_convert_l1; 1756 doconv:=tc_equal; 1757 end 1758 else if (def_from.typ=variantdef) and is_interfacecom_or_dispinterface(def_to) then 1759 begin 1760 { corbainterfaces not accepted, until we have 1761 runtime support for them in Variants (sergei) } 1762 doconv:=tc_variant_2_interface; 1763 eq:=te_convert_l2; 1764 end 1765 { ugly, but delphi allows it (enables typecasting ordinals/ 1766 enums of any size to pointer-based object defs) } 1767 { in Java enums /are/ class instances, and hence such 1768 typecasts must not be treated as integer-like conversions; 1769 arbitrary constants cannot be converted into classes/ 1770 pointer-based values either on the JVM -> always return 1771 false and let it be handled by the regular explicit type 1772 casting code 1773 } 1774 else if (not(target_info.system in systems_jvm) and 1775 ((def_from.typ=enumdef) or 1776 (def_from.typ=orddef))) and 1777 (m_delphi in current_settings.modeswitches) and 1778 (cdo_explicit in cdoptions) then 1779 begin 1780 doconv:=tc_int_2_int; 1781 eq:=te_convert_l1; 1782 end; 1783 end; 1784 end; 1785 1786 classrefdef : 1787 begin 1788 { similar to pointerdef wrt forwards } 1789 if assigned(def_to.typesym) and 1790 (tclassrefdef(def_to).pointeddef.typ=forwarddef) or 1791 ((def_from.typ=classrefdef) and 1792 (tclassrefdef(def_from).pointeddef.typ=forwarddef)) then 1793 begin 1794 if (def_from.typesym=def_to.typesym) or 1795 (fromtreetype=niln) then 1796 eq:=te_equal; 1797 end 1798 else 1799 { class reference types } 1800 if (def_from.typ=classrefdef) then 1801 begin 1802 if equal_defs(tclassrefdef(def_from).pointeddef,tclassrefdef(def_to).pointeddef) then 1803 begin 1804 eq:=te_equal; 1805 end 1806 else 1807 begin 1808 doconv:=tc_equal; 1809 if (cdo_explicit in cdoptions) or 1810 def_is_related(tobjectdef(tclassrefdef(def_from).pointeddef), 1811 tobjectdef(tclassrefdef(def_to).pointeddef)) then 1812 eq:=te_convert_l1; 1813 end; 1814 end 1815 else 1816 if (m_delphi in current_settings.modeswitches) and 1817 is_voidpointer(def_from) then 1818 begin 1819 doconv:=tc_equal; 1820 { prefer pointer-pointer assignments } 1821 eq:=te_convert_l2; 1822 end 1823 else 1824 { nil is compatible with class references } 1825 if (fromtreetype=niln) then 1826 begin 1827 doconv:=tc_equal; 1828 eq:=te_convert_l1; 1829 end 1830 else 1831 { id is compatible with all classref types } 1832 if (def_from=objc_idtype) then 1833 begin 1834 doconv:=tc_equal; 1835 eq:=te_convert_l1; 1836 end; 1837 end; 1838 1839 filedef : 1840 begin 1841 { typed files are all equal to the abstract file type 1842 name TYPEDFILE in system.pp in is_equal in types.pas 1843 the problem is that it sholud be also compatible to FILE 1844 but this would leed to a problem for ASSIGN RESET and REWRITE 1845 when trying to find the good overloaded function !! 1846 so all file function are doubled in system.pp 1847 this is not very beautiful !!} 1848 if (def_from.typ=filedef) then 1849 begin 1850 if (tfiledef(def_from).filetyp=tfiledef(def_to).filetyp) then 1851 begin 1852 if 1853 ( 1854 (tfiledef(def_from).typedfiledef=nil) and 1855 (tfiledef(def_to).typedfiledef=nil) 1856 ) or 1857 ( 1858 (tfiledef(def_from).typedfiledef<>nil) and 1859 (tfiledef(def_to).typedfiledef<>nil) and 1860 equal_defs(tfiledef(def_from).typedfiledef,tfiledef(def_to).typedfiledef) 1861 ) or 1862 ( 1863 (tfiledef(def_from).filetyp = ft_typed) and 1864 (tfiledef(def_to).filetyp = ft_typed) and 1865 ( 1866 (tfiledef(def_from).typedfiledef = tdef(voidtype)) or 1867 (tfiledef(def_to).typedfiledef = tdef(voidtype)) 1868 ) 1869 ) then 1870 begin 1871 eq:=te_equal; 1872 end; 1873 end 1874 else 1875 if ((tfiledef(def_from).filetyp = ft_untyped) and 1876 (tfiledef(def_to).filetyp = ft_typed)) or 1877 ((tfiledef(def_from).filetyp = ft_typed) and 1878 (tfiledef(def_to).filetyp = ft_untyped)) then 1879 begin 1880 doconv:=tc_equal; 1881 eq:=te_convert_l1; 1882 end; 1883 end; 1884 end; 1885 1886 recorddef : 1887 begin 1888 { interface -> guid } 1889 if (def_to=rec_tguid) and 1890 (is_interfacecom_or_dispinterface(def_from)) then 1891 begin 1892 doconv:=tc_intf_2_guid; 1893 eq:=te_convert_l1; 1894 end; 1895 end; 1896 1897 formaldef : 1898 begin 1899 doconv:=tc_equal; 1900 if (def_from.typ=formaldef) then 1901 eq:=te_equal 1902 else 1903 { Just about everything can be converted to a formaldef...} 1904 if not (def_from.typ in [abstractdef,errordef]) then 1905 eq:=te_convert_l6; 1906 end; 1907 end; 1908 1909 { if we didn't find an appropriate type conversion yet 1910 then we search also the := operator } 1911 if (eq=te_incompatible) and 1912 { make sure there is not a single variant if variants } 1913 { are not allowed (otherwise if only cdo_check_operator } 1914 { and e.g. fromdef=stringdef and todef=variantdef, then } 1915 { the test will still succeed } 1916 ((cdo_allow_variant in cdoptions) or 1917 ((def_from.typ<>variantdef) and 1918 (def_to.typ<>variantdef) and 1919 { internal typeconversions always have to be bitcasts (except for 1920 variants) } 1921 not(cdo_internal in cdoptions) 1922 ) 1923 ) and 1924 ( 1925 { Check for variants? } 1926 ( 1927 (cdo_allow_variant in cdoptions) and 1928 ((def_from.typ=variantdef) or (def_to.typ=variantdef)) 1929 ) or 1930 { Check for operators? } 1931 ( 1932 (cdo_check_operator in cdoptions) and 1933 ((def_from.typ<>variantdef) or (def_to.typ<>variantdef)) 1934 ) 1935 ) then 1936 begin 1937 operatorpd:=search_assignment_operator(def_from,def_to,cdo_explicit in cdoptions); 1938 if assigned(operatorpd) then 1939 eq:=te_convert_operator; 1940 end; 1941 1942 { update convtype for te_equal when it is not yet set } 1943 if (eq=te_equal) and 1944 (doconv=tc_not_possible) then 1945 doconv:=tc_equal; 1946 1947 compare_defs_ext:=eq; 1948 end; 1949 1950 equal_defsnull1951 function equal_defs(def_from,def_to:tdef):boolean; 1952 var 1953 convtyp : tconverttype; 1954 pd : tprocdef; 1955 begin 1956 { Compare defs with nothingn and no explicit typecasts and 1957 searching for overloaded operators is not needed } 1958 equal_defs:=(compare_defs_ext(def_from,def_to,nothingn,convtyp,pd,[])>=te_equal); 1959 end; 1960 1961 compare_defsnull1962 function compare_defs(def_from,def_to:tdef;fromtreetype:tnodetype):tequaltype; 1963 var 1964 doconv : tconverttype; 1965 pd : tprocdef; 1966 begin 1967 compare_defs:=compare_defs_ext(def_from,def_to,fromtreetype,doconv,pd,[cdo_check_operator,cdo_allow_variant]); 1968 end; 1969 1970 is_subequalnull1971 function is_subequal(def1, def2: tdef): boolean; 1972 var 1973 basedef1,basedef2 : tenumdef; 1974 1975 Begin 1976 is_subequal := false; 1977 if assigned(def1) and assigned(def2) then 1978 Begin 1979 if (def1.typ = orddef) and (def2.typ = orddef) then 1980 Begin 1981 { see p.47 of Turbo Pascal 7.01 manual for the separation of types } 1982 { range checking for case statements is done with adaptrange } 1983 case torddef(def1).ordtype of 1984 u8bit,u16bit,u32bit,u64bit, 1985 s8bit,s16bit,s32bit,s64bit : 1986 is_subequal:=(torddef(def2).ordtype in [s64bit,u64bit,s32bit,u32bit,u8bit,s8bit,s16bit,u16bit]); 1987 pasbool1,pasbool8,pasbool16,pasbool32,pasbool64, 1988 bool8bit,bool16bit,bool32bit,bool64bit : 1989 is_subequal:=(torddef(def2).ordtype in [pasbool1,pasbool8,pasbool16,pasbool32,pasbool64,bool8bit,bool16bit,bool32bit,bool64bit]); 1990 uchar : 1991 is_subequal:=(torddef(def2).ordtype=uchar); 1992 uwidechar : 1993 is_subequal:=(torddef(def2).ordtype=uwidechar); 1994 end; 1995 end 1996 else 1997 Begin 1998 { Check if both basedefs are equal } 1999 if (def1.typ=enumdef) and (def2.typ=enumdef) then 2000 Begin 2001 { get both basedefs } 2002 basedef1:=tenumdef(def1); 2003 while assigned(basedef1.basedef) do 2004 basedef1:=basedef1.basedef; 2005 basedef2:=tenumdef(def2); 2006 while assigned(basedef2.basedef) do 2007 basedef2:=basedef2.basedef; 2008 is_subequal:=(basedef1=basedef2); 2009 end; 2010 end; 2011 end; 2012 end; 2013 2014 potentially_incompatible_univ_parasnull2015 function potentially_incompatible_univ_paras(def1, def2: tdef): boolean; 2016 begin 2017 result := 2018 { not entirely safe: different records can be passed differently 2019 depending on the types of their fields, but they're hard to compare 2020 (variant records, bitpacked vs non-bitpacked) } 2021 ((def1.typ in [floatdef,recorddef,arraydef,filedef,variantdef]) and 2022 (def1.typ<>def2.typ)) or 2023 { pointers, ordinals and small sets are all passed the same} 2024 (((def1.typ in [orddef,enumdef,pointerdef,procvardef,classrefdef]) or 2025 (is_class_or_interface_or_objc(def1)) or 2026 is_dynamic_array(def1) or 2027 is_smallset(def1) or 2028 is_ansistring(def1) or 2029 is_unicodestring(def1)) <> 2030 (def2.typ in [orddef,enumdef,pointerdef,procvardef,classrefdef]) or 2031 (is_class_or_interface_or_objc(def2)) or 2032 is_dynamic_array(def2) or 2033 is_smallset(def2) or 2034 is_ansistring(def2) or 2035 is_unicodestring(def2)) or 2036 { shortstrings } 2037 (is_shortstring(def1)<> 2038 is_shortstring(def2)) or 2039 { winlike widestrings } 2040 (is_widestring(def1)<> 2041 is_widestring(def2)) or 2042 { TP-style objects } 2043 (is_object(def1) <> 2044 is_object(def2)); 2045 end; 2046 2047 compare_parasnull2048 function compare_paras(para1,para2 : TFPObjectList; acp : tcompare_paras_type; cpoptions: tcompare_paras_options):tequaltype; 2049 2050 var 2051 currpara1, 2052 currpara2 : tparavarsym; 2053 eq,lowesteq : tequaltype; 2054 hpd : tprocdef; 2055 convtype : tconverttype; 2056 cdoptions : tcompare_defs_options; 2057 i1,i2 : byte; 2058 begin 2059 compare_paras:=te_incompatible; 2060 cdoptions:=[cdo_parameter,cdo_check_operator,cdo_allow_variant,cdo_strict_undefined_check]; 2061 { we need to parse the list from left-right so the 2062 not-default parameters are checked first } 2063 lowesteq:=high(tequaltype); 2064 i1:=0; 2065 i2:=0; 2066 if cpo_ignorehidden in cpoptions then 2067 begin 2068 while (i1<para1.count) and 2069 (vo_is_hidden_para in tparavarsym(para1[i1]).varoptions) do 2070 inc(i1); 2071 while (i2<para2.count) and 2072 (vo_is_hidden_para in tparavarsym(para2[i2]).varoptions) do 2073 inc(i2); 2074 end; 2075 if cpo_ignoreframepointer in cpoptions then 2076 begin 2077 if (i1<para1.count) and 2078 (vo_is_parentfp in tparavarsym(para1[i1]).varoptions) then 2079 inc(i1); 2080 if (i2<para2.count) and 2081 (vo_is_parentfp in tparavarsym(para2[i2]).varoptions) then 2082 inc(i2); 2083 end; 2084 while (i1<para1.count) and (i2<para2.count) do 2085 begin 2086 eq:=te_incompatible; 2087 2088 currpara1:=tparavarsym(para1[i1]); 2089 currpara2:=tparavarsym(para2[i2]); 2090 2091 { Unique types must match exact } 2092 if ((df_unique in currpara1.vardef.defoptions) or (df_unique in currpara2.vardef.defoptions)) and 2093 (currpara1.vardef<>currpara2.vardef) then 2094 exit; 2095 2096 { Handle hidden parameters separately, because self is 2097 defined as voidpointer for methodpointers } 2098 if (vo_is_hidden_para in currpara1.varoptions) or 2099 (vo_is_hidden_para in currpara2.varoptions) then 2100 begin 2101 { both must be hidden } 2102 if (vo_is_hidden_para in currpara1.varoptions)<>(vo_is_hidden_para in currpara2.varoptions) then 2103 exit; 2104 eq:=te_exact; 2105 if (([vo_is_self,vo_is_vmt]*currpara1.varoptions)=[]) and 2106 (([vo_is_self,vo_is_vmt]*currpara2.varoptions)=[]) then 2107 begin 2108 if not(cpo_ignorevarspez in cpoptions) and 2109 (currpara1.varspez<>currpara2.varspez) then 2110 exit; 2111 eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn, 2112 convtype,hpd,cdoptions); 2113 end 2114 else if ([vo_is_self,vo_is_vmt]*currpara1.varoptions)<> 2115 ([vo_is_self,vo_is_vmt]*currpara2.varoptions) then 2116 eq:=te_incompatible; 2117 end 2118 else 2119 begin 2120 case acp of 2121 cp_value_equal_const : 2122 begin 2123 { this one is used for matching parameters from a call 2124 statement to a procdef -> univ state can't be equal 2125 in any case since the call statement does not contain 2126 any information about that } 2127 if ( 2128 not(cpo_ignorevarspez in cpoptions) and 2129 (currpara1.varspez<>currpara2.varspez) and 2130 ((currpara1.varspez in [vs_var,vs_out,vs_constref]) or 2131 (currpara2.varspez in [vs_var,vs_out,vs_constref])) 2132 ) then 2133 exit; 2134 eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn, 2135 convtype,hpd,cdoptions); 2136 end; 2137 cp_all : 2138 begin 2139 { used to resolve forward definitions -> headers must 2140 match exactly, including the "univ" specifier } 2141 if (not(cpo_ignorevarspez in cpoptions) and 2142 (currpara1.varspez<>currpara2.varspez)) or 2143 (currpara1.univpara<>currpara2.univpara) then 2144 exit; 2145 eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn, 2146 convtype,hpd,cdoptions); 2147 end; 2148 cp_procvar : 2149 begin 2150 if not(cpo_ignorevarspez in cpoptions) and 2151 (currpara1.varspez<>currpara2.varspez) then 2152 exit; 2153 { "univ" state doesn't matter here: from univ to non-univ 2154 matches if the types are compatible (i.e., as usual), 2155 from from non-univ to univ also matches if the types 2156 have the same size (checked below) } 2157 eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn, 2158 convtype,hpd,cdoptions); 2159 { Parameters must be at least equal otherwise the are incompatible } 2160 if (eq<te_equal) then 2161 eq:=te_incompatible; 2162 end; 2163 else 2164 eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn, 2165 convtype,hpd,cdoptions); 2166 end; 2167 end; 2168 { check type } 2169 if eq=te_incompatible then 2170 begin 2171 { special case: "univ" parameters match if their size is equal } 2172 if not(cpo_ignoreuniv in cpoptions) and 2173 currpara2.univpara and 2174 is_valid_univ_para_type(currpara1.vardef) and 2175 (currpara1.vardef.size=currpara2.vardef.size) then 2176 begin 2177 { only pick as last choice } 2178 eq:=te_convert_l5; 2179 if (acp=cp_procvar) and 2180 (cpo_warn_incompatible_univ in cpoptions) then 2181 begin 2182 { if the types may be passed in different ways by the 2183 calling convention then this can lead to crashes 2184 (note: not an exhaustive check, and failing this 2185 this check does not mean things will crash on all 2186 platforms) } 2187 if potentially_incompatible_univ_paras(currpara1.vardef,currpara2.vardef) then 2188 Message2(type_w_procvar_univ_conflicting_para,currpara1.vardef.typename,currpara2.vardef.typename) 2189 end; 2190 end 2191 else if (cpo_generic in cpoptions) then 2192 begin 2193 if equal_genfunc_paradefs(currpara1.vardef,currpara2.vardef,currpara1.owner,currpara2.owner) then 2194 eq:=te_exact 2195 else 2196 exit; 2197 end 2198 else 2199 exit; 2200 end; 2201 if (eq=te_equal) and 2202 (cpo_generic in cpoptions) then 2203 begin 2204 if is_open_array(currpara1.vardef) and 2205 is_open_array(currpara2.vardef) then 2206 begin 2207 if equal_genfunc_paradefs(tarraydef(currpara1.vardef).elementdef,tarraydef(currpara2.vardef).elementdef,currpara1.owner,currpara2.owner) then 2208 eq:=te_exact; 2209 end 2210 else 2211 { for the purpose of forward declarations two equal specializations 2212 are considered as exactly equal } 2213 if (df_specialization in tstoreddef(currpara1.vardef).defoptions) and 2214 (df_specialization in tstoreddef(currpara2.vardef).defoptions) then 2215 eq:=te_exact; 2216 end; 2217 { open strings can never match exactly, since you cannot define } 2218 { a separate "open string" type -> we have to be able to } 2219 { consider those as exact when resolving forward definitions. } 2220 { The same goes for array of const. Open arrays are handled } 2221 { already (if their element types match exactly, they are } 2222 { considered to be an exact match) } 2223 { And also for "inline defined" function parameter definitions } 2224 { (i.e., function types directly declared in a parameter list) } 2225 if (is_array_of_const(currpara1.vardef) or 2226 is_open_string(currpara1.vardef) or 2227 ((currpara1.vardef.typ = procvardef) and 2228 not(assigned(currpara1.vardef.typesym)))) and 2229 (eq=te_equal) and 2230 (cpo_openequalisexact in cpoptions) then 2231 eq:=te_exact; 2232 if eq<lowesteq then 2233 lowesteq:=eq; 2234 { also check default value if both have it declared } 2235 if (cpo_comparedefaultvalue in cpoptions) then 2236 begin 2237 if assigned(currpara1.defaultconstsym) and 2238 assigned(currpara2.defaultconstsym) then 2239 begin 2240 if not equal_constsym(tconstsym(currpara1.defaultconstsym),tconstsym(currpara2.defaultconstsym),true) then 2241 exit; 2242 end 2243 { cannot have that the second (= implementation) has a default value declared and the 2244 other (interface) doesn't } 2245 else if not assigned(currpara1.defaultconstsym) and assigned(currpara2.defaultconstsym) then 2246 exit; 2247 end; 2248 if not(cpo_compilerproc in cpoptions) and 2249 not(cpo_rtlproc in cpoptions) and 2250 is_ansistring(currpara1.vardef) and 2251 is_ansistring(currpara2.vardef) and 2252 (tstringdef(currpara1.vardef).encoding<>tstringdef(currpara2.vardef).encoding) and 2253 ((tstringdef(currpara1.vardef).encoding=globals.CP_NONE) or 2254 (tstringdef(currpara2.vardef).encoding=globals.CP_NONE) 2255 ) then 2256 eq:=te_convert_l1; 2257 if eq<lowesteq then 2258 lowesteq:=eq; 2259 inc(i1); 2260 inc(i2); 2261 if cpo_ignorehidden in cpoptions then 2262 begin 2263 while (i1<para1.count) and 2264 (vo_is_hidden_para in tparavarsym(para1[i1]).varoptions) do 2265 inc(i1); 2266 while (i2<para2.count) and 2267 (vo_is_hidden_para in tparavarsym(para2[i2]).varoptions) do 2268 inc(i2); 2269 end; 2270 if cpo_ignoreframepointer in cpoptions then 2271 begin 2272 if (i1<para1.count) and 2273 (vo_is_parentfp in tparavarsym(para1[i1]).varoptions) then 2274 inc(i1); 2275 if (i2<para2.count) and 2276 (vo_is_parentfp in tparavarsym(para2[i2]).varoptions) then 2277 inc(i2); 2278 end; 2279 end; 2280 { when both lists are empty then the parameters are equal. Also 2281 when one list is empty and the other has a parameter with default 2282 value assigned then the parameters are also equal } 2283 if ((i1>=para1.count) and (i2>=para2.count)) or 2284 ((cpo_allowdefaults in cpoptions) and 2285 (((i1<para1.count) and assigned(tparavarsym(para1[i1]).defaultconstsym)) or 2286 ((i2<para2.count) and assigned(tparavarsym(para2[i2]).defaultconstsym)))) then 2287 compare_paras:=lowesteq; 2288 end; 2289 2290 proc_to_procvar_equalnull2291 function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef;checkincompatibleuniv: boolean):tequaltype; 2292 var 2293 eq: tequaltype; 2294 po_comp: tprocoptions; 2295 pa_comp: tcompare_paras_options; 2296 begin 2297 proc_to_procvar_equal:=te_incompatible; 2298 if not(assigned(def1)) or not(assigned(def2)) then 2299 exit; 2300 { check for method pointer and local procedure pointer: 2301 a) anything but procvars can be assigned to blocks 2302 b) if one is a procedure of object, the other also has to be one 2303 ("object static procedure" is equal to procedure as well) 2304 (except for block) 2305 c) if one is a pure address, the other also has to be one 2306 except if def1 is a global proc and def2 is a nested procdef 2307 (global procedures can be converted into nested procvars) 2308 d) if def1 is a nested procedure, then def2 has to be a nested 2309 procvar and def1 has to have the po_delphi_nested_cc option 2310 e) if def1 is a procvar, def1 and def2 both have to be nested or 2311 non-nested (we don't allow assignments from non-nested to 2312 nested procvars to make sure that we can still implement 2313 nested procvars using trampolines -- e.g., this would be 2314 necessary for LLVM or CIL as long as they do not have support 2315 for Delphi-style frame pointer parameter passing) } 2316 if is_block(def2) then { a) } 2317 { can't explicitly check against procvars here, because 2318 def1 may already be a procvar due to a proc_to_procvar; 2319 this is checked in the type conversion node itself -> ok } 2320 else if 2321 ((def1.is_methodpointer and not (po_staticmethod in def1.procoptions))<> { b) } 2322 (def2.is_methodpointer and not (po_staticmethod in def2.procoptions))) or 2323 ((def1.is_addressonly<>def2.is_addressonly) and { c) } 2324 (is_nested_pd(def1) or 2325 not is_nested_pd(def2))) or 2326 ((def1.typ=procdef) and { d) } 2327 is_nested_pd(def1) and 2328 (not(po_delphi_nested_cc in def1.procoptions) or 2329 not is_nested_pd(def2))) or 2330 ((def1.typ=procvardef) and { e) } 2331 (is_nested_pd(def1)<>is_nested_pd(def2))) then 2332 exit; 2333 pa_comp:=[cpo_ignoreframepointer]; 2334 if is_block(def2) then 2335 include(pa_comp,cpo_ignorehidden); 2336 if checkincompatibleuniv then 2337 include(pa_comp,cpo_warn_incompatible_univ); 2338 { check return value and options, methodpointer is already checked } 2339 po_comp:=[po_interrupt,po_iocheck,po_varargs,po_far]; 2340 { check static only if we compare method pointers } 2341 if def1.is_methodpointer and def2.is_methodpointer then 2342 include(po_comp,po_staticmethod); 2343 if (m_delphi in current_settings.modeswitches) then 2344 exclude(po_comp,po_varargs); 2345 { for blocks, the calling convention doesn't matter because we have to 2346 generate a wrapper anyway } 2347 if ((po_is_block in def2.procoptions) or 2348 (def1.proccalloption=def2.proccalloption)) and 2349 ((po_comp * def1.procoptions)= (po_comp * def2.procoptions)) and 2350 equal_defs(def1.returndef,def2.returndef) then 2351 begin 2352 { return equal type based on the parameters, but a proc->procvar 2353 is never exact, so map an exact match of the parameters to 2354 te_equal } 2355 eq:=compare_paras(def1.paras,def2.paras,cp_procvar,pa_comp); 2356 if eq=te_exact then 2357 eq:=te_equal; 2358 if (eq=te_equal) then 2359 begin 2360 { prefer non-nested to non-nested over non-nested to nested } 2361 if (is_nested_pd(def1)<>is_nested_pd(def2)) then 2362 eq:=te_convert_l1; 2363 { in case of non-block to block, we need a type conversion } 2364 if (po_is_block in def1.procoptions) <> (po_is_block in def2.procoptions) then 2365 eq:=te_convert_l1; 2366 end; 2367 proc_to_procvar_equal:=eq; 2368 end; 2369 end; 2370 2371 compatible_childmethod_resultdefnull2372 function compatible_childmethod_resultdef(parentretdef, childretdef: tdef): boolean; 2373 begin 2374 compatible_childmethod_resultdef := 2375 (equal_defs(parentretdef,childretdef)) or 2376 ((parentretdef.typ=objectdef) and 2377 (childretdef.typ=objectdef) and 2378 is_class_or_interface_or_objc_or_java(parentretdef) and 2379 is_class_or_interface_or_objc_or_java(childretdef) and 2380 (def_is_related(tobjectdef(childretdef),tobjectdef(parentretdef)))) 2381 end; 2382 2383 find_implemented_interfacenull2384 function find_implemented_interface(impldef,intfdef:tobjectdef):timplementedinterface; 2385 var 2386 implintf : timplementedinterface; 2387 i : longint; 2388 begin 2389 if not assigned(impldef) then 2390 internalerror(2013102301); 2391 if not assigned(intfdef) then 2392 internalerror(2013102302); 2393 result:=nil; 2394 if not assigned(impldef.implementedinterfaces) then 2395 exit; 2396 for i:=0 to impldef.implementedinterfaces.count-1 do 2397 begin 2398 implintf:=timplementedinterface(impldef.implementedinterfaces[i]); 2399 if equal_defs(implintf.intfdef,intfdef) then 2400 begin 2401 result:=implintf; 2402 exit; 2403 end; 2404 end; 2405 end; 2406 2407 stringdef_is_relatednull2408 function stringdef_is_related(curdef:tstringdef;otherdef:tdef):boolean; 2409 begin 2410 result:= 2411 (target_info.system in systems_jvm) and 2412 (((curdef.stringtype in [st_unicodestring,st_widestring]) and 2413 ((otherdef=java_jlobject) or 2414 (otherdef=java_jlstring))) or 2415 ((curdef.stringtype=st_ansistring) and 2416 ((otherdef=java_jlobject) or 2417 (otherdef=java_ansistring)))); 2418 end; 2419 2420 recorddef_is_relatednull2421 function recorddef_is_related(curdef:trecorddef;otherdef:tdef):boolean; 2422 begin 2423 { records are implemented via classes in the JVM target, and are 2424 all descendents of the java_fpcbaserecordtype class } 2425 result:=false; 2426 if (target_info.system in systems_jvm) then 2427 begin 2428 if otherdef.typ=objectdef then 2429 begin 2430 otherdef:=find_real_class_definition(tobjectdef(otherdef),false); 2431 if (otherdef=java_jlobject) or 2432 (otherdef=java_fpcbaserecordtype) then 2433 result:=true 2434 end; 2435 end; 2436 end; 2437 2438 2439 { true if prot implements d (or if they are equal) } is_related_interface_multiplenull2440 function is_related_interface_multiple(prot:tobjectdef;d:tdef):boolean; 2441 var 2442 i : longint; 2443 begin 2444 { objcprotocols have multiple inheritance, all protocols from which 2445 the current protocol inherits are stored in implementedinterfaces } 2446 result:=prot=d; 2447 if result then 2448 exit; 2449 2450 for i:=0 to prot.implementedinterfaces.count-1 do 2451 begin 2452 result:=is_related_interface_multiple(timplementedinterface(prot.implementedinterfaces[i]).intfdef,d); 2453 if result then 2454 exit; 2455 end; 2456 end; 2457 2458 objectdef_is_relatednull2459 function objectdef_is_related(curdef:tobjectdef;otherdef:tdef):boolean; 2460 var 2461 realself, 2462 hp : tobjectdef; 2463 begin 2464 if (otherdef.typ=objectdef) then 2465 otherdef:=find_real_class_definition(tobjectdef(otherdef),false); 2466 realself:=find_real_class_definition(curdef,false); 2467 if realself=otherdef then 2468 begin 2469 result:=true; 2470 exit; 2471 end; 2472 2473 if (realself.objecttype in [odt_objcclass,odt_objcprotocol]) and 2474 (otherdef=objc_idtype) then 2475 begin 2476 result:=true; 2477 exit; 2478 end; 2479 2480 if (otherdef.typ<>objectdef) then 2481 begin 2482 result:=false; 2483 exit; 2484 end; 2485 2486 { Objective-C protocols and Java interfaces can use multiple 2487 inheritance } 2488 if (realself.objecttype in [odt_objcprotocol,odt_interfacejava]) then 2489 begin 2490 result:=is_related_interface_multiple(realself,otherdef); 2491 exit; 2492 end; 2493 2494 { formally declared Objective-C and Java classes match Objective-C/Java 2495 classes with the same name. In case of Java, the package must also 2496 match (still required even though we looked up the real definitions 2497 above, because these may be two different formal declarations that 2498 cannot be resolved yet) } 2499 if (realself.objecttype in [odt_objcclass,odt_javaclass]) and 2500 (tobjectdef(otherdef).objecttype=curdef.objecttype) and 2501 ((oo_is_formal in curdef.objectoptions) or 2502 (oo_is_formal in tobjectdef(otherdef).objectoptions)) and 2503 (curdef.objrealname^=tobjectdef(otherdef).objrealname^) then 2504 begin 2505 { check package name for Java } 2506 if curdef.objecttype=odt_objcclass then 2507 result:=true 2508 else 2509 begin 2510 result:= 2511 assigned(curdef.import_lib)=assigned(tobjectdef(otherdef).import_lib); 2512 if result and 2513 assigned(curdef.import_lib) then 2514 result:=curdef.import_lib^=tobjectdef(otherdef).import_lib^; 2515 end; 2516 exit; 2517 end; 2518 2519 hp:=realself.childof; 2520 while assigned(hp) do 2521 begin 2522 if equal_defs(hp,otherdef) then 2523 begin 2524 result:=true; 2525 exit; 2526 end; 2527 hp:=hp.childof; 2528 end; 2529 result:=false; 2530 end; 2531 2532 def_is_relatednull2533 function def_is_related(curdef,otherdef:tdef):boolean; 2534 begin 2535 if not assigned(curdef) then 2536 internalerror(2013102303); 2537 case curdef.typ of 2538 stringdef: 2539 result:=stringdef_is_related(tstringdef(curdef),otherdef); 2540 recorddef: 2541 result:=recorddef_is_related(trecorddef(curdef),otherdef); 2542 objectdef: 2543 result:=objectdef_is_related(tobjectdef(curdef),otherdef); 2544 else 2545 result:=false; 2546 end; 2547 end; 2548 2549 equal_genfunc_paradefsnull2550 function equal_genfunc_paradefs(fwdef,currdef:tdef;fwpdst,currpdst:tsymtable): boolean; 2551 begin 2552 result:=false; 2553 { for open array parameters, typesym might not be assigned } 2554 if assigned(fwdef.typesym) and (sp_generic_para in fwdef.typesym.symoptions) and 2555 assigned(currdef.typesym) and (sp_generic_para in currdef.typesym.symoptions) and 2556 (fwdef.owner=fwpdst) and 2557 (currdef.owner=currpdst) then 2558 begin 2559 { the forward declaration may have constraints } 2560 if not (df_genconstraint in currdef.defoptions) and (currdef.typ=undefineddef) and 2561 ((fwdef.typ=undefineddef) or (df_genconstraint in fwdef.defoptions)) then 2562 result:=true; 2563 end 2564 end; 2565 2566 end. 2567