defcmp.pas 116 KB

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