defcmp.pas 98 KB

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