defcmp.pas 133 KB

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