defcmp.pas 100 KB

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