defcmp.pas 99 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196
  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. if is_pwidechar(def_to)=(m_default_unicodestring in current_settings.modeswitches) then
  1104. eq:=te_convert_l2
  1105. else
  1106. eq:=te_convert_l3
  1107. end
  1108. else
  1109. if (cdo_explicit in cdoptions) or (fromtreetype = arrayconstructorn) then
  1110. begin
  1111. { pchar(ansistring) }
  1112. if is_pchar(def_to) and
  1113. is_ansistring(def_from) then
  1114. begin
  1115. doconv:=tc_ansistring_2_pchar;
  1116. eq:=te_convert_l1;
  1117. end
  1118. else
  1119. { pwidechar(widestring) }
  1120. if is_pwidechar(def_to) and
  1121. is_wide_or_unicode_string(def_from) then
  1122. begin
  1123. doconv:=tc_ansistring_2_pchar;
  1124. eq:=te_convert_l1;
  1125. end;
  1126. end;
  1127. end;
  1128. orddef :
  1129. begin
  1130. { char constant to zero terminated string constant }
  1131. if (fromtreetype in [ordconstn,arrayconstructorn]) then
  1132. begin
  1133. if (is_char(def_from) or is_widechar(def_from)) and
  1134. (is_pchar(def_to) or is_pwidechar(def_to)) then
  1135. begin
  1136. doconv:=tc_cchar_2_pchar;
  1137. if is_pwidechar(def_to)=(m_default_unicodestring in current_settings.modeswitches) then
  1138. eq:=te_convert_l1
  1139. else
  1140. eq:=te_convert_l2
  1141. end
  1142. else
  1143. if (m_delphi in current_settings.modeswitches) and is_integer(def_from) then
  1144. begin
  1145. doconv:=tc_cord_2_pointer;
  1146. eq:=te_convert_l5;
  1147. end;
  1148. end;
  1149. { allow explicit typecasts from ordinals to pointer.
  1150. Support for delphi compatibility
  1151. Support constructs like pointer(cardinal-cardinal) or pointer(longint+cardinal) where
  1152. the result of the ordinal operation is int64 also on 32 bit platforms.
  1153. It is also used by the compiler internally for inc(pointer,ordinal) }
  1154. if (eq=te_incompatible) and
  1155. not is_void(def_from) and
  1156. (
  1157. (
  1158. (cdo_explicit in cdoptions) and
  1159. (
  1160. (m_delphi in current_settings.modeswitches) or
  1161. { Don't allow pchar(char) in fpc modes }
  1162. is_integer(def_from)
  1163. )
  1164. ) or
  1165. (cdo_internal in cdoptions)
  1166. ) then
  1167. begin
  1168. doconv:=tc_int_2_int;
  1169. eq:=te_convert_l1;
  1170. end;
  1171. end;
  1172. enumdef :
  1173. begin
  1174. { allow explicit typecasts from enums to pointer.
  1175. Support for delphi compatibility
  1176. }
  1177. { in Java enums /are/ class instances, and hence such
  1178. typecasts must not be treated as integer-like conversions
  1179. }
  1180. if (((cdo_explicit in cdoptions) and
  1181. ((m_delphi in current_settings.modeswitches) or
  1182. (target_info.system in systems_jvm)
  1183. )
  1184. ) or
  1185. (cdo_internal in cdoptions)
  1186. ) then
  1187. begin
  1188. { in Java enums /are/ class instances, and hence such
  1189. typecasts must not be treated as integer-like
  1190. conversions
  1191. }
  1192. if target_info.system in systems_jvm then
  1193. begin
  1194. doconv:=tc_equal;
  1195. eq:=te_convert_l1;
  1196. end
  1197. else if m_delphi in current_settings.modeswitches then
  1198. begin
  1199. doconv:=tc_int_2_int;
  1200. eq:=te_convert_l1;
  1201. end;
  1202. end;
  1203. end;
  1204. arraydef :
  1205. begin
  1206. { string constant (which can be part of array constructor)
  1207. to zero terminated string constant }
  1208. if (((fromtreetype = arrayconstructorn) and
  1209. { can't use is_chararray, because returns false for }
  1210. { array constructors }
  1211. is_char(tarraydef(def_from).elementdef)) or
  1212. (fromtreetype = stringconstn)) and
  1213. (is_pchar(def_to) or is_pwidechar(def_to)) then
  1214. begin
  1215. doconv:=tc_cstring_2_pchar;
  1216. if ((m_default_unicodestring in current_settings.modeswitches) xor
  1217. is_pchar(def_to)) then
  1218. eq:=te_convert_l2
  1219. else
  1220. eq:=te_convert_l3;
  1221. end
  1222. else
  1223. { chararray to pointer }
  1224. if (is_zero_based_array(def_from) or
  1225. is_open_array(def_from)) and
  1226. equal_defs(tarraydef(def_from).elementdef,tpointerdef(def_to).pointeddef) then
  1227. begin
  1228. doconv:=tc_array_2_pointer;
  1229. { don't prefer the pchar overload when a constant
  1230. string was passed }
  1231. if fromtreetype=stringconstn then
  1232. eq:=te_convert_l2
  1233. else
  1234. eq:=te_convert_l1;
  1235. end
  1236. else
  1237. { dynamic array to pointer, delphi only }
  1238. if (m_delphi in current_settings.modeswitches) and
  1239. is_dynamic_array(def_from) and
  1240. is_voidpointer(def_to) then
  1241. begin
  1242. eq:=te_equal;
  1243. end;
  1244. end;
  1245. pointerdef :
  1246. begin
  1247. {$ifdef x86}
  1248. { check for far pointers }
  1249. if (tpointerdef(def_from).x86pointertyp<>tpointerdef(def_to).x86pointertyp) then
  1250. begin
  1251. if fromtreetype=niln then
  1252. eq:=te_equal
  1253. else
  1254. eq:=te_incompatible;
  1255. end
  1256. else
  1257. {$endif x86}
  1258. { the types can be forward type, handle before normal type check !! }
  1259. if assigned(def_to.typesym) and
  1260. ((tpointerdef(def_to).pointeddef.typ=forwarddef) or
  1261. (tpointerdef(def_from).pointeddef.typ=forwarddef)) then
  1262. begin
  1263. if (def_from.typesym=def_to.typesym) or
  1264. (fromtreetype=niln) then
  1265. eq:=te_equal
  1266. end
  1267. else
  1268. { same types }
  1269. if equal_defs(tpointerdef(def_from).pointeddef,tpointerdef(def_to).pointeddef) then
  1270. begin
  1271. eq:=te_equal
  1272. end
  1273. else
  1274. { child class pointer can be assigned to anchestor pointers }
  1275. if (
  1276. (tpointerdef(def_from).pointeddef.typ=objectdef) and
  1277. (tpointerdef(def_to).pointeddef.typ=objectdef) and
  1278. tobjectdef(tpointerdef(def_from).pointeddef).is_related(
  1279. tobjectdef(tpointerdef(def_to).pointeddef))
  1280. ) then
  1281. begin
  1282. doconv:=tc_equal;
  1283. eq:=te_convert_l1;
  1284. end
  1285. else
  1286. { all pointers can be assigned to void-pointer }
  1287. if is_void(tpointerdef(def_to).pointeddef) then
  1288. begin
  1289. doconv:=tc_equal;
  1290. { give pwidechar,pchar a penalty so it prefers
  1291. conversion to ansistring }
  1292. if is_pchar(def_from) or
  1293. is_pwidechar(def_from) then
  1294. eq:=te_convert_l2
  1295. else
  1296. eq:=te_convert_l1;
  1297. end
  1298. else
  1299. { all pointers can be assigned from void-pointer }
  1300. if is_void(tpointerdef(def_from).pointeddef) or
  1301. { all pointers can be assigned from void-pointer or formaldef pointer, check
  1302. tw3777.pp if you change this }
  1303. (tpointerdef(def_from).pointeddef.typ=formaldef) then
  1304. begin
  1305. doconv:=tc_equal;
  1306. { give pwidechar a penalty so it prefers
  1307. conversion to pchar }
  1308. if is_pwidechar(def_to) then
  1309. eq:=te_convert_l2
  1310. else
  1311. eq:=te_convert_l1;
  1312. end
  1313. { id = generic class instance. metaclasses are also
  1314. class instances themselves. }
  1315. else if ((def_from=objc_idtype) and
  1316. (def_to=objc_metaclasstype)) or
  1317. ((def_to=objc_idtype) and
  1318. (def_from=objc_metaclasstype)) then
  1319. begin
  1320. doconv:=tc_equal;
  1321. eq:=te_convert_l2;
  1322. end;
  1323. end;
  1324. procvardef :
  1325. begin
  1326. { procedure variable can be assigned to an void pointer,
  1327. this is not allowed for complex procvars }
  1328. if (is_void(tpointerdef(def_to).pointeddef) or
  1329. (m_mac_procvar in current_settings.modeswitches)) and
  1330. tprocvardef(def_from).is_addressonly then
  1331. begin
  1332. doconv:=tc_equal;
  1333. eq:=te_convert_l1;
  1334. end;
  1335. end;
  1336. procdef :
  1337. begin
  1338. { procedure variable can be assigned to an void pointer,
  1339. this not allowed for methodpointers }
  1340. if (m_mac_procvar in current_settings.modeswitches) and
  1341. tprocdef(def_from).is_addressonly then
  1342. begin
  1343. doconv:=tc_proc_2_procvar;
  1344. eq:=te_convert_l2;
  1345. end;
  1346. end;
  1347. classrefdef,
  1348. objectdef :
  1349. begin
  1350. { implicit pointer object and class reference types
  1351. can be assigned to void pointers, but it is less
  1352. preferred than assigning to a related objectdef }
  1353. if (
  1354. is_implicit_pointer_object_type(def_from) or
  1355. (def_from.typ=classrefdef)
  1356. ) and
  1357. (tpointerdef(def_to).pointeddef.typ=orddef) and
  1358. (torddef(tpointerdef(def_to).pointeddef).ordtype=uvoid) then
  1359. begin
  1360. doconv:=tc_equal;
  1361. eq:=te_convert_l2;
  1362. end
  1363. else if (is_objc_class_or_protocol(def_from) and
  1364. (def_to=objc_idtype)) or
  1365. { classrefs are also instances in Objective-C,
  1366. hence they're also assignment-cpmpatible with
  1367. id }
  1368. (is_objcclassref(def_from) and
  1369. ((def_to=objc_metaclasstype) or
  1370. (def_to=objc_idtype))) then
  1371. begin
  1372. doconv:=tc_equal;
  1373. eq:=te_convert_l2;
  1374. end;
  1375. end;
  1376. end;
  1377. end;
  1378. setdef :
  1379. begin
  1380. case def_from.typ of
  1381. setdef :
  1382. begin
  1383. if assigned(tsetdef(def_from).elementdef) and
  1384. assigned(tsetdef(def_to).elementdef) then
  1385. begin
  1386. { sets with the same size (packset setting), element
  1387. base type and the same range are equal }
  1388. if equal_defs(tsetdef(def_from).elementdef,tsetdef(def_to).elementdef) and
  1389. (tsetdef(def_from).setbase=tsetdef(def_to).setbase) and
  1390. (tsetdef(def_from).setmax=tsetdef(def_to).setmax) and
  1391. (def_from.size=def_to.size) then
  1392. eq:=te_equal
  1393. else if is_subequal(tsetdef(def_from).elementdef,tsetdef(def_to).elementdef) then
  1394. begin
  1395. eq:=te_convert_l1;
  1396. doconv:=tc_set_to_set;
  1397. end;
  1398. end
  1399. else
  1400. begin
  1401. { empty set is compatible with everything }
  1402. eq:=te_convert_l1;
  1403. doconv:=tc_set_to_set;
  1404. end;
  1405. end;
  1406. arraydef :
  1407. begin
  1408. { automatic arrayconstructor -> set conversion }
  1409. if is_array_constructor(def_from) then
  1410. begin
  1411. doconv:=tc_arrayconstructor_2_set;
  1412. eq:=te_convert_l1;
  1413. end;
  1414. end;
  1415. end;
  1416. end;
  1417. procvardef :
  1418. begin
  1419. case def_from.typ of
  1420. procdef :
  1421. begin
  1422. { proc -> procvar }
  1423. if (m_tp_procvar in current_settings.modeswitches) or
  1424. (m_mac_procvar in current_settings.modeswitches) then
  1425. begin
  1426. subeq:=proc_to_procvar_equal(tprocdef(def_from),tprocvardef(def_to),cdo_warn_incompatible_univ in cdoptions);
  1427. if subeq>te_incompatible then
  1428. begin
  1429. doconv:=tc_proc_2_procvar;
  1430. if subeq>te_convert_l5 then
  1431. eq:=pred(subeq)
  1432. else
  1433. eq:=subeq;
  1434. end;
  1435. end;
  1436. end;
  1437. procvardef :
  1438. begin
  1439. { procvar -> procvar }
  1440. eq:=proc_to_procvar_equal(tprocvardef(def_from),tprocvardef(def_to),cdo_warn_incompatible_univ in cdoptions);
  1441. end;
  1442. pointerdef :
  1443. begin
  1444. { nil is compatible with procvars }
  1445. if (fromtreetype=niln) then
  1446. begin
  1447. if not Tprocvardef(def_to).is_addressonly then
  1448. {Nil to method pointers requires to convert a single
  1449. pointer nil value to a two pointer procvardef.}
  1450. doconv:=tc_nil_2_methodprocvar
  1451. else
  1452. doconv:=tc_equal;
  1453. eq:=te_convert_l1;
  1454. end
  1455. else
  1456. { for example delphi allows the assignement from pointers }
  1457. { to procedure variables }
  1458. if (m_pointer_2_procedure in current_settings.modeswitches) and
  1459. is_void(tpointerdef(def_from).pointeddef) and
  1460. tprocvardef(def_to).is_addressonly then
  1461. begin
  1462. doconv:=tc_equal;
  1463. eq:=te_convert_l1;
  1464. end;
  1465. end;
  1466. end;
  1467. end;
  1468. objectdef :
  1469. begin
  1470. { object pascal objects }
  1471. if (def_from.typ=objectdef) and
  1472. (tobjectdef(def_from).is_related(tobjectdef(def_to))) then
  1473. begin
  1474. doconv:=tc_equal;
  1475. { also update in htypechk.pas/var_para_allowed if changed
  1476. here }
  1477. eq:=te_convert_l3;
  1478. end
  1479. { string -> java.lang.string }
  1480. else if (def_to=java_jlstring) and
  1481. ((def_from.typ=stringdef) or
  1482. (fromtreetype=stringconstn)) then
  1483. begin
  1484. if is_wide_or_unicode_string(def_from) or
  1485. ((fromtreetype=stringconstn) and
  1486. (cs_refcountedstrings in current_settings.localswitches) and
  1487. (m_default_unicodestring in current_settings.modeswitches)) then
  1488. begin
  1489. doconv:=tc_equal;
  1490. eq:=te_equal
  1491. end
  1492. else
  1493. begin
  1494. doconv:=tc_string_2_string;
  1495. eq:=te_convert_l2;
  1496. end;
  1497. end
  1498. else if (def_to=java_jlstring) and
  1499. is_anychar(def_from) then
  1500. begin
  1501. doconv:=tc_char_2_string;
  1502. eq:=te_convert_l2
  1503. end
  1504. else
  1505. { specific to implicit pointer object types }
  1506. if is_implicit_pointer_object_type(def_to) then
  1507. begin
  1508. { void pointer also for delphi mode }
  1509. if (m_delphi in current_settings.modeswitches) and
  1510. is_voidpointer(def_from) then
  1511. begin
  1512. doconv:=tc_equal;
  1513. { prefer pointer-pointer assignments }
  1514. eq:=te_convert_l2;
  1515. end
  1516. else
  1517. { nil is compatible with class instances and interfaces }
  1518. if (fromtreetype=niln) then
  1519. begin
  1520. doconv:=tc_equal;
  1521. eq:=te_convert_l1;
  1522. end
  1523. { All Objective-C classes are compatible with ID }
  1524. else if is_objc_class_or_protocol(def_to) and
  1525. (def_from=objc_idtype) then
  1526. begin
  1527. doconv:=tc_equal;
  1528. eq:=te_convert_l2;
  1529. end
  1530. { classes can be assigned to interfaces
  1531. (same with objcclass and objcprotocol) }
  1532. else if ((is_interface(def_to) and
  1533. is_class(def_from)) or
  1534. (is_objcprotocol(def_to) and
  1535. is_objcclass(def_from)) or
  1536. (is_javainterface(def_to) and
  1537. is_javaclass(def_from))) and
  1538. assigned(tobjectdef(def_from).ImplementedInterfaces) then
  1539. begin
  1540. { we've to search in parent classes as well }
  1541. hobjdef:=tobjectdef(def_from);
  1542. while assigned(hobjdef) do
  1543. begin
  1544. if hobjdef.find_implemented_interface(tobjectdef(def_to))<>nil then
  1545. begin
  1546. if is_interface(def_to) then
  1547. doconv:=tc_class_2_intf
  1548. else
  1549. { for Objective-C, we don't have to do anything special }
  1550. doconv:=tc_equal;
  1551. { don't prefer this over objectdef->objectdef }
  1552. eq:=te_convert_l2;
  1553. break;
  1554. end;
  1555. hobjdef:=hobjdef.childof;
  1556. end;
  1557. end
  1558. { Interface 2 GUID handling }
  1559. else if (def_to=tdef(rec_tguid)) and
  1560. (fromtreetype=typen) and
  1561. is_interface(def_from) and
  1562. assigned(tobjectdef(def_from).iidguid) then
  1563. begin
  1564. eq:=te_convert_l1;
  1565. doconv:=tc_equal;
  1566. end
  1567. else if (def_from.typ=variantdef) and is_interfacecom_or_dispinterface(def_to) then
  1568. begin
  1569. { corbainterfaces not accepted, until we have
  1570. runtime support for them in Variants (sergei) }
  1571. doconv:=tc_variant_2_interface;
  1572. eq:=te_convert_l2;
  1573. end
  1574. { ugly, but delphi allows it (enables typecasting ordinals/
  1575. enums of any size to pointer-based object defs) }
  1576. { in Java enums /are/ class instances, and hence such
  1577. typecasts must not be treated as integer-like conversions;
  1578. arbitrary constants cannot be converted into classes/
  1579. pointer-based values either on the JVM -> always return
  1580. false and let it be handled by the regular explicit type
  1581. casting code
  1582. }
  1583. else if (not(target_info.system in systems_jvm) and
  1584. ((def_from.typ=enumdef) or
  1585. (def_from.typ=orddef))) and
  1586. (m_delphi in current_settings.modeswitches) and
  1587. (cdo_explicit in cdoptions) then
  1588. begin
  1589. doconv:=tc_int_2_int;
  1590. eq:=te_convert_l1;
  1591. end;
  1592. end;
  1593. end;
  1594. classrefdef :
  1595. begin
  1596. { similar to pointerdef wrt forwards }
  1597. if assigned(def_to.typesym) and
  1598. (tclassrefdef(def_to).pointeddef.typ=forwarddef) or
  1599. ((def_from.typ=classrefdef) and
  1600. (tclassrefdef(def_from).pointeddef.typ=forwarddef)) then
  1601. begin
  1602. if (def_from.typesym=def_to.typesym) or
  1603. (fromtreetype=niln) then
  1604. eq:=te_equal;
  1605. end
  1606. else
  1607. { class reference types }
  1608. if (def_from.typ=classrefdef) then
  1609. begin
  1610. if equal_defs(tclassrefdef(def_from).pointeddef,tclassrefdef(def_to).pointeddef) then
  1611. begin
  1612. eq:=te_equal;
  1613. end
  1614. else
  1615. begin
  1616. doconv:=tc_equal;
  1617. if (cdo_explicit in cdoptions) or
  1618. tobjectdef(tclassrefdef(def_from).pointeddef).is_related(
  1619. tobjectdef(tclassrefdef(def_to).pointeddef)) then
  1620. eq:=te_convert_l1;
  1621. end;
  1622. end
  1623. else
  1624. if (m_delphi in current_settings.modeswitches) and
  1625. is_voidpointer(def_from) then
  1626. begin
  1627. doconv:=tc_equal;
  1628. { prefer pointer-pointer assignments }
  1629. eq:=te_convert_l2;
  1630. end
  1631. else
  1632. { nil is compatible with class references }
  1633. if (fromtreetype=niln) then
  1634. begin
  1635. doconv:=tc_equal;
  1636. eq:=te_convert_l1;
  1637. end
  1638. else
  1639. { id is compatible with all classref types }
  1640. if (def_from=objc_idtype) then
  1641. begin
  1642. doconv:=tc_equal;
  1643. eq:=te_convert_l1;
  1644. end;
  1645. end;
  1646. filedef :
  1647. begin
  1648. { typed files are all equal to the abstract file type
  1649. name TYPEDFILE in system.pp in is_equal in types.pas
  1650. the problem is that it sholud be also compatible to FILE
  1651. but this would leed to a problem for ASSIGN RESET and REWRITE
  1652. when trying to find the good overloaded function !!
  1653. so all file function are doubled in system.pp
  1654. this is not very beautiful !!}
  1655. if (def_from.typ=filedef) then
  1656. begin
  1657. if (tfiledef(def_from).filetyp=tfiledef(def_to).filetyp) then
  1658. begin
  1659. if
  1660. (
  1661. (tfiledef(def_from).typedfiledef=nil) and
  1662. (tfiledef(def_to).typedfiledef=nil)
  1663. ) or
  1664. (
  1665. (tfiledef(def_from).typedfiledef<>nil) and
  1666. (tfiledef(def_to).typedfiledef<>nil) and
  1667. equal_defs(tfiledef(def_from).typedfiledef,tfiledef(def_to).typedfiledef)
  1668. ) or
  1669. (
  1670. (tfiledef(def_from).filetyp = ft_typed) and
  1671. (tfiledef(def_to).filetyp = ft_typed) and
  1672. (
  1673. (tfiledef(def_from).typedfiledef = tdef(voidtype)) or
  1674. (tfiledef(def_to).typedfiledef = tdef(voidtype))
  1675. )
  1676. ) then
  1677. begin
  1678. eq:=te_equal;
  1679. end;
  1680. end
  1681. else
  1682. if ((tfiledef(def_from).filetyp = ft_untyped) and
  1683. (tfiledef(def_to).filetyp = ft_typed)) or
  1684. ((tfiledef(def_from).filetyp = ft_typed) and
  1685. (tfiledef(def_to).filetyp = ft_untyped)) then
  1686. begin
  1687. doconv:=tc_equal;
  1688. eq:=te_convert_l1;
  1689. end;
  1690. end;
  1691. end;
  1692. recorddef :
  1693. begin
  1694. { interface -> guid }
  1695. if (def_to=rec_tguid) and
  1696. (is_interfacecom_or_dispinterface(def_from)) then
  1697. begin
  1698. doconv:=tc_intf_2_guid;
  1699. eq:=te_convert_l1;
  1700. end;
  1701. end;
  1702. formaldef :
  1703. begin
  1704. doconv:=tc_equal;
  1705. if (def_from.typ=formaldef) then
  1706. eq:=te_equal
  1707. else
  1708. { Just about everything can be converted to a formaldef...}
  1709. if not (def_from.typ in [abstractdef,errordef]) then
  1710. eq:=te_convert_l2;
  1711. end;
  1712. end;
  1713. { if we didn't find an appropriate type conversion yet
  1714. then we search also the := operator }
  1715. if (eq=te_incompatible) and
  1716. { make sure there is not a single variant if variants }
  1717. { are not allowed (otherwise if only cdo_check_operator }
  1718. { and e.g. fromdef=stringdef and todef=variantdef, then }
  1719. { the test will still succeed }
  1720. ((cdo_allow_variant in cdoptions) or
  1721. ((def_from.typ<>variantdef) and
  1722. (def_to.typ<>variantdef) and
  1723. { internal typeconversions always have to be bitcasts (except for
  1724. variants) }
  1725. not(cdo_internal in cdoptions)
  1726. )
  1727. ) and
  1728. (
  1729. { Check for variants? }
  1730. (
  1731. (cdo_allow_variant in cdoptions) and
  1732. ((def_from.typ=variantdef) or (def_to.typ=variantdef))
  1733. ) or
  1734. { Check for operators? }
  1735. (
  1736. (cdo_check_operator in cdoptions) and
  1737. ((def_from.typ<>variantdef) or (def_to.typ<>variantdef))
  1738. )
  1739. ) then
  1740. begin
  1741. operatorpd:=search_assignment_operator(def_from,def_to,cdo_explicit in cdoptions);
  1742. if assigned(operatorpd) then
  1743. eq:=te_convert_operator;
  1744. end;
  1745. { update convtype for te_equal when it is not yet set }
  1746. if (eq=te_equal) and
  1747. (doconv=tc_not_possible) then
  1748. doconv:=tc_equal;
  1749. compare_defs_ext:=eq;
  1750. end;
  1751. function equal_defs(def_from,def_to:tdef):boolean;
  1752. var
  1753. convtyp : tconverttype;
  1754. pd : tprocdef;
  1755. begin
  1756. { Compare defs with nothingn and no explicit typecasts and
  1757. searching for overloaded operators is not needed }
  1758. equal_defs:=(compare_defs_ext(def_from,def_to,nothingn,convtyp,pd,[])>=te_equal);
  1759. end;
  1760. function compare_defs(def_from,def_to:tdef;fromtreetype:tnodetype):tequaltype;
  1761. var
  1762. doconv : tconverttype;
  1763. pd : tprocdef;
  1764. begin
  1765. compare_defs:=compare_defs_ext(def_from,def_to,fromtreetype,doconv,pd,[cdo_check_operator,cdo_allow_variant]);
  1766. end;
  1767. function is_subequal(def1, def2: tdef): boolean;
  1768. var
  1769. basedef1,basedef2 : tenumdef;
  1770. Begin
  1771. is_subequal := false;
  1772. if assigned(def1) and assigned(def2) then
  1773. Begin
  1774. if (def1.typ = orddef) and (def2.typ = orddef) then
  1775. Begin
  1776. { see p.47 of Turbo Pascal 7.01 manual for the separation of types }
  1777. { range checking for case statements is done with testrange }
  1778. case torddef(def1).ordtype of
  1779. u8bit,u16bit,u32bit,u64bit,
  1780. s8bit,s16bit,s32bit,s64bit :
  1781. is_subequal:=(torddef(def2).ordtype in [s64bit,u64bit,s32bit,u32bit,u8bit,s8bit,s16bit,u16bit]);
  1782. pasbool8,pasbool16,pasbool32,pasbool64,
  1783. bool8bit,bool16bit,bool32bit,bool64bit :
  1784. is_subequal:=(torddef(def2).ordtype in [pasbool8,pasbool16,pasbool32,pasbool64,bool8bit,bool16bit,bool32bit,bool64bit]);
  1785. uchar :
  1786. is_subequal:=(torddef(def2).ordtype=uchar);
  1787. uwidechar :
  1788. is_subequal:=(torddef(def2).ordtype=uwidechar);
  1789. end;
  1790. end
  1791. else
  1792. Begin
  1793. { Check if both basedefs are equal }
  1794. if (def1.typ=enumdef) and (def2.typ=enumdef) then
  1795. Begin
  1796. { get both basedefs }
  1797. basedef1:=tenumdef(def1);
  1798. while assigned(basedef1.basedef) do
  1799. basedef1:=basedef1.basedef;
  1800. basedef2:=tenumdef(def2);
  1801. while assigned(basedef2.basedef) do
  1802. basedef2:=basedef2.basedef;
  1803. is_subequal:=(basedef1=basedef2);
  1804. end;
  1805. end;
  1806. end;
  1807. end;
  1808. function potentially_incompatible_univ_paras(def1, def2: tdef): boolean;
  1809. begin
  1810. result :=
  1811. { not entirely safe: different records can be passed differently
  1812. depending on the types of their fields, but they're hard to compare
  1813. (variant records, bitpacked vs non-bitpacked) }
  1814. ((def1.typ in [floatdef,recorddef,arraydef,filedef,variantdef]) and
  1815. (def1.typ<>def2.typ)) or
  1816. { pointers, ordinals and small sets are all passed the same}
  1817. (((def1.typ in [orddef,enumdef,pointerdef,procvardef,classrefdef]) or
  1818. (is_class_or_interface_or_objc(def1)) or
  1819. is_dynamic_array(def1) or
  1820. is_smallset(def1) or
  1821. is_ansistring(def1) or
  1822. is_unicodestring(def1)) <>
  1823. (def2.typ in [orddef,enumdef,pointerdef,procvardef,classrefdef]) or
  1824. (is_class_or_interface_or_objc(def2)) or
  1825. is_dynamic_array(def2) or
  1826. is_smallset(def2) or
  1827. is_ansistring(def2) or
  1828. is_unicodestring(def2)) or
  1829. { shortstrings }
  1830. (is_shortstring(def1)<>
  1831. is_shortstring(def2)) or
  1832. { winlike widestrings }
  1833. (is_widestring(def1)<>
  1834. is_widestring(def2)) or
  1835. { TP-style objects }
  1836. (is_object(def1) <>
  1837. is_object(def2));
  1838. end;
  1839. function compare_paras(para1,para2 : TFPObjectList; acp : tcompare_paras_type; cpoptions: tcompare_paras_options):tequaltype;
  1840. var
  1841. currpara1,
  1842. currpara2 : tparavarsym;
  1843. eq,lowesteq : tequaltype;
  1844. hpd : tprocdef;
  1845. convtype : tconverttype;
  1846. cdoptions : tcompare_defs_options;
  1847. i1,i2 : byte;
  1848. begin
  1849. compare_paras:=te_incompatible;
  1850. cdoptions:=[cdo_parameter,cdo_check_operator,cdo_allow_variant,cdo_strict_undefined_check];
  1851. { we need to parse the list from left-right so the
  1852. not-default parameters are checked first }
  1853. lowesteq:=high(tequaltype);
  1854. i1:=0;
  1855. i2:=0;
  1856. if cpo_ignorehidden in cpoptions then
  1857. begin
  1858. while (i1<para1.count) and
  1859. (vo_is_hidden_para in tparavarsym(para1[i1]).varoptions) do
  1860. inc(i1);
  1861. while (i2<para2.count) and
  1862. (vo_is_hidden_para in tparavarsym(para2[i2]).varoptions) do
  1863. inc(i2);
  1864. end;
  1865. if cpo_ignoreframepointer in cpoptions then
  1866. begin
  1867. if (i1<para1.count) and
  1868. (vo_is_parentfp in tparavarsym(para1[i1]).varoptions) then
  1869. inc(i1);
  1870. if (i2<para2.count) and
  1871. (vo_is_parentfp in tparavarsym(para2[i2]).varoptions) then
  1872. inc(i2);
  1873. end;
  1874. while (i1<para1.count) and (i2<para2.count) do
  1875. begin
  1876. eq:=te_incompatible;
  1877. currpara1:=tparavarsym(para1[i1]);
  1878. currpara2:=tparavarsym(para2[i2]);
  1879. { Unique types must match exact }
  1880. if ((df_unique in currpara1.vardef.defoptions) or (df_unique in currpara2.vardef.defoptions)) and
  1881. (currpara1.vardef<>currpara2.vardef) then
  1882. exit;
  1883. { Handle hidden parameters separately, because self is
  1884. defined as voidpointer for methodpointers }
  1885. if (vo_is_hidden_para in currpara1.varoptions) or
  1886. (vo_is_hidden_para in currpara2.varoptions) then
  1887. begin
  1888. { both must be hidden }
  1889. if (vo_is_hidden_para in currpara1.varoptions)<>(vo_is_hidden_para in currpara2.varoptions) then
  1890. exit;
  1891. eq:=te_exact;
  1892. if not(vo_is_self in currpara1.varoptions) and
  1893. not(vo_is_self in currpara2.varoptions) then
  1894. begin
  1895. if not(cpo_ignorevarspez in cpoptions) and
  1896. (currpara1.varspez<>currpara2.varspez) then
  1897. exit;
  1898. eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
  1899. convtype,hpd,cdoptions);
  1900. end;
  1901. end
  1902. else
  1903. begin
  1904. case acp of
  1905. cp_value_equal_const :
  1906. begin
  1907. { this one is used for matching parameters from a call
  1908. statement to a procdef -> univ state can't be equal
  1909. in any case since the call statement does not contain
  1910. any information about that }
  1911. if (
  1912. not(cpo_ignorevarspez in cpoptions) and
  1913. (currpara1.varspez<>currpara2.varspez) and
  1914. ((currpara1.varspez in [vs_var,vs_out,vs_constref]) or
  1915. (currpara2.varspez in [vs_var,vs_out,vs_constref]))
  1916. ) then
  1917. exit;
  1918. eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
  1919. convtype,hpd,cdoptions);
  1920. end;
  1921. cp_all :
  1922. begin
  1923. { used to resolve forward definitions -> headers must
  1924. match exactly, including the "univ" specifier }
  1925. if (not(cpo_ignorevarspez in cpoptions) and
  1926. (currpara1.varspez<>currpara2.varspez)) or
  1927. (currpara1.univpara<>currpara2.univpara) then
  1928. exit;
  1929. eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
  1930. convtype,hpd,cdoptions);
  1931. end;
  1932. cp_procvar :
  1933. begin
  1934. if not(cpo_ignorevarspez in cpoptions) and
  1935. (currpara1.varspez<>currpara2.varspez) then
  1936. exit;
  1937. { "univ" state doesn't matter here: from univ to non-univ
  1938. matches if the types are compatible (i.e., as usual),
  1939. from from non-univ to univ also matches if the types
  1940. have the same size (checked below) }
  1941. eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
  1942. convtype,hpd,cdoptions);
  1943. { Parameters must be at least equal otherwise the are incompatible }
  1944. if (eq<te_equal) then
  1945. eq:=te_incompatible;
  1946. end;
  1947. else
  1948. eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
  1949. convtype,hpd,cdoptions);
  1950. end;
  1951. end;
  1952. { check type }
  1953. if eq=te_incompatible then
  1954. begin
  1955. { special case: "univ" parameters match if their size is equal }
  1956. if not(cpo_ignoreuniv in cpoptions) and
  1957. currpara2.univpara and
  1958. is_valid_univ_para_type(currpara1.vardef) and
  1959. (currpara1.vardef.size=currpara2.vardef.size) then
  1960. begin
  1961. { only pick as last choice }
  1962. eq:=te_convert_l5;
  1963. if (acp=cp_procvar) and
  1964. (cpo_warn_incompatible_univ in cpoptions) then
  1965. begin
  1966. { if the types may be passed in different ways by the
  1967. calling convention then this can lead to crashes
  1968. (note: not an exhaustive check, and failing this
  1969. this check does not mean things will crash on all
  1970. platforms) }
  1971. if potentially_incompatible_univ_paras(currpara1.vardef,currpara2.vardef) then
  1972. Message2(type_w_procvar_univ_conflicting_para,currpara1.vardef.typename,currpara2.vardef.typename)
  1973. end;
  1974. end
  1975. else
  1976. exit;
  1977. end;
  1978. { open strings can never match exactly, since you cannot define }
  1979. { a separate "open string" type -> we have to be able to }
  1980. { consider those as exact when resolving forward definitions. }
  1981. { The same goes for array of const. Open arrays are handled }
  1982. { already (if their element types match exactly, they are }
  1983. { considered to be an exact match) }
  1984. { And also for "inline defined" function parameter definitions }
  1985. { (i.e., function types directly declared in a parameter list) }
  1986. if (is_array_of_const(currpara1.vardef) or
  1987. is_open_string(currpara1.vardef) or
  1988. ((currpara1.vardef.typ = procvardef) and
  1989. not(assigned(currpara1.vardef.typesym)))) and
  1990. (eq=te_equal) and
  1991. (cpo_openequalisexact in cpoptions) then
  1992. eq:=te_exact;
  1993. if eq<lowesteq then
  1994. lowesteq:=eq;
  1995. { also check default value if both have it declared }
  1996. if (cpo_comparedefaultvalue in cpoptions) then
  1997. begin
  1998. if assigned(currpara1.defaultconstsym) and
  1999. assigned(currpara2.defaultconstsym) then
  2000. begin
  2001. if not equal_constsym(tconstsym(currpara1.defaultconstsym),tconstsym(currpara2.defaultconstsym)) then
  2002. exit;
  2003. end
  2004. { cannot have that the second (= implementation) has a default value declared and the
  2005. other (interface) doesn't }
  2006. else if not assigned(currpara1.defaultconstsym) and assigned(currpara2.defaultconstsym) then
  2007. exit;
  2008. end;
  2009. if not(cpo_compilerproc in cpoptions) and
  2010. not(cpo_rtlproc in cpoptions) and
  2011. is_ansistring(currpara1.vardef) and
  2012. is_ansistring(currpara2.vardef) and
  2013. (tstringdef(currpara1.vardef).encoding<>tstringdef(currpara2.vardef).encoding) and
  2014. ((tstringdef(currpara1.vardef).encoding=globals.CP_NONE) or
  2015. (tstringdef(currpara2.vardef).encoding=globals.CP_NONE)
  2016. ) then
  2017. eq:=te_convert_l1;
  2018. if eq<lowesteq then
  2019. lowesteq:=eq;
  2020. inc(i1);
  2021. inc(i2);
  2022. if cpo_ignorehidden in cpoptions then
  2023. begin
  2024. while (i1<para1.count) and
  2025. (vo_is_hidden_para in tparavarsym(para1[i1]).varoptions) do
  2026. inc(i1);
  2027. while (i2<para2.count) and
  2028. (vo_is_hidden_para in tparavarsym(para2[i2]).varoptions) do
  2029. inc(i2);
  2030. end;
  2031. if cpo_ignoreframepointer in cpoptions then
  2032. begin
  2033. if (i1<para1.count) and
  2034. (vo_is_parentfp in tparavarsym(para1[i1]).varoptions) then
  2035. inc(i1);
  2036. if (i2<para2.count) and
  2037. (vo_is_parentfp in tparavarsym(para2[i2]).varoptions) then
  2038. inc(i2);
  2039. end;
  2040. end;
  2041. { when both lists are empty then the parameters are equal. Also
  2042. when one list is empty and the other has a parameter with default
  2043. value assigned then the parameters are also equal }
  2044. if ((i1>=para1.count) and (i2>=para2.count)) or
  2045. ((cpo_allowdefaults in cpoptions) and
  2046. (((i1<para1.count) and assigned(tparavarsym(para1[i1]).defaultconstsym)) or
  2047. ((i2<para2.count) and assigned(tparavarsym(para2[i2]).defaultconstsym)))) then
  2048. compare_paras:=lowesteq;
  2049. end;
  2050. function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef;checkincompatibleuniv: boolean):tequaltype;
  2051. var
  2052. eq: tequaltype;
  2053. po_comp: tprocoptions;
  2054. pa_comp: tcompare_paras_options;
  2055. begin
  2056. proc_to_procvar_equal:=te_incompatible;
  2057. if not(assigned(def1)) or not(assigned(def2)) then
  2058. exit;
  2059. { check for method pointer and local procedure pointer:
  2060. a) if one is a procedure of object, the other also has to be one
  2061. b) if one is a pure address, the other also has to be one
  2062. except if def1 is a global proc and def2 is a nested procdef
  2063. (global procedures can be converted into nested procvars)
  2064. c) if def1 is a nested procedure, then def2 has to be a nested
  2065. procvar and def1 has to have the po_delphi_nested_cc option
  2066. d) if def1 is a procvar, def1 and def2 both have to be nested or
  2067. non-nested (we don't allow assignments from non-nested to
  2068. nested procvars to make sure that we can still implement
  2069. nested procvars using trampolines -- e.g., this would be
  2070. necessary for LLVM or CIL as long as they do not have support
  2071. for Delphi-style frame pointer parameter passing) }
  2072. if (def1.is_methodpointer<>def2.is_methodpointer) or { a) }
  2073. ((def1.is_addressonly<>def2.is_addressonly) and { b) }
  2074. (is_nested_pd(def1) or
  2075. not is_nested_pd(def2))) or
  2076. ((def1.typ=procdef) and { c) }
  2077. is_nested_pd(def1) and
  2078. (not(po_delphi_nested_cc in def1.procoptions) or
  2079. not is_nested_pd(def2))) or
  2080. ((def1.typ=procvardef) and { d) }
  2081. (is_nested_pd(def1)<>is_nested_pd(def2))) then
  2082. exit;
  2083. pa_comp:=[cpo_ignoreframepointer];
  2084. if checkincompatibleuniv then
  2085. include(pa_comp,cpo_warn_incompatible_univ);
  2086. { check return value and options, methodpointer is already checked }
  2087. po_comp:=[po_interrupt,po_iocheck,po_varargs];
  2088. { check static only if we compare method pointers }
  2089. if def1.is_methodpointer then
  2090. include(po_comp,po_staticmethod);
  2091. if (m_delphi in current_settings.modeswitches) then
  2092. exclude(po_comp,po_varargs);
  2093. if (def1.proccalloption=def2.proccalloption) and
  2094. ((po_comp * def1.procoptions)= (po_comp * def2.procoptions)) and
  2095. equal_defs(def1.returndef,def2.returndef) then
  2096. begin
  2097. { return equal type based on the parameters, but a proc->procvar
  2098. is never exact, so map an exact match of the parameters to
  2099. te_equal }
  2100. eq:=compare_paras(def1.paras,def2.paras,cp_procvar,pa_comp);
  2101. if eq=te_exact then
  2102. eq:=te_equal;
  2103. if (eq=te_equal) then
  2104. begin
  2105. { prefer non-nested to non-nested over non-nested to nested }
  2106. if (is_nested_pd(def1)<>is_nested_pd(def2)) then
  2107. eq:=te_convert_l1;
  2108. end;
  2109. proc_to_procvar_equal:=eq;
  2110. end;
  2111. end;
  2112. function compatible_childmethod_resultdef(parentretdef, childretdef: tdef): boolean;
  2113. begin
  2114. compatible_childmethod_resultdef :=
  2115. (equal_defs(parentretdef,childretdef)) or
  2116. ((parentretdef.typ=objectdef) and
  2117. (childretdef.typ=objectdef) and
  2118. is_class_or_interface_or_objc_or_java(parentretdef) and
  2119. is_class_or_interface_or_objc_or_java(childretdef) and
  2120. (tobjectdef(childretdef).is_related(tobjectdef(parentretdef))))
  2121. end;
  2122. end.