defcmp.pas 131 KB

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