defcmp.pas 66 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553
  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 = (cpo_allowdefaults,cpo_ignorehidden,cpo_allowconvert,cpo_comparedefaultvalue);
  29. tcompare_paras_options = set of tcompare_paras_option;
  30. tcompare_defs_option = (cdo_internal,cdo_explicit,cdo_check_operator,cdo_allow_variant,cdo_parameter);
  31. tcompare_defs_options = set of tcompare_defs_option;
  32. tconverttype = (tc_none,
  33. tc_equal,
  34. tc_not_possible,
  35. tc_string_2_string,
  36. tc_char_2_string,
  37. tc_char_2_chararray,
  38. tc_pchar_2_string,
  39. tc_cchar_2_pchar,
  40. tc_cstring_2_pchar,
  41. tc_cstring_2_int,
  42. tc_ansistring_2_pchar,
  43. tc_string_2_chararray,
  44. tc_chararray_2_string,
  45. tc_array_2_pointer,
  46. tc_pointer_2_array,
  47. tc_int_2_int,
  48. tc_int_2_bool,
  49. tc_int_2_string,
  50. tc_bool_2_bool,
  51. tc_bool_2_int,
  52. tc_real_2_real,
  53. tc_int_2_real,
  54. tc_real_2_currency,
  55. tc_proc_2_procvar,
  56. tc_arrayconstructor_2_set,
  57. tc_load_smallset,
  58. tc_cord_2_pointer,
  59. tc_intf_2_string,
  60. tc_intf_2_guid,
  61. tc_class_2_intf,
  62. tc_char_2_char,
  63. tc_normal_2_smallset,
  64. tc_dynarray_2_openarray,
  65. tc_pwchar_2_string,
  66. tc_variant_2_dynarray,
  67. tc_dynarray_2_variant,
  68. tc_variant_2_enum,
  69. tc_enum_2_variant,
  70. tc_interface_2_variant,
  71. tc_variant_2_interface,
  72. tc_array_2_dynarray
  73. );
  74. function compare_defs_ext(def_from,def_to : tdef;
  75. fromtreetype : tnodetype;
  76. var doconv : tconverttype;
  77. var operatorpd : tprocdef;
  78. cdoptions:tcompare_defs_options):tequaltype;
  79. { Returns if the type def_from can be converted to def_to or if both types are equal }
  80. function compare_defs(def_from,def_to:tdef;fromtreetype:tnodetype):tequaltype;
  81. { Returns true, if def1 and def2 are semantically the same }
  82. function equal_defs(def_from,def_to:tdef):boolean;
  83. { Checks for type compatibility (subgroups of type)
  84. used for case statements... probably missing stuff
  85. to use on other types }
  86. function is_subequal(def1, def2: tdef): boolean;
  87. {# true, if two parameter lists are equal
  88. if acp is cp_none, all have to match exactly
  89. if acp is cp_value_equal_const call by value
  90. and call by const parameter are assumed as
  91. equal
  92. allowdefaults indicates if default value parameters
  93. are allowed (in this case, the search order will first
  94. search for a routine with default parameters, before
  95. searching for the same definition with no parameters)
  96. }
  97. function compare_paras(para1,para2 : TFPObjectList; acp : tcompare_paras_type; cpoptions: tcompare_paras_options):tequaltype;
  98. { True if a function can be assigned to a procvar }
  99. { changed first argument type to pabstractprocdef so that it can also be }
  100. { used to test compatibility between two pprocvardefs (JM) }
  101. function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef):tequaltype;
  102. implementation
  103. uses
  104. verbose,systems,
  105. symtable,symsym,
  106. defutil,symutil;
  107. function compare_defs_ext(def_from,def_to : tdef;
  108. fromtreetype : tnodetype;
  109. var doconv : tconverttype;
  110. var operatorpd : tprocdef;
  111. cdoptions:tcompare_defs_options):tequaltype;
  112. { Tbasetype:
  113. uvoid,
  114. u8bit,u16bit,u32bit,u64bit,
  115. s8bit,s16bit,s32bit,s64bit,
  116. bool8bit,bool16bit,bool32bit,bool64bit,
  117. uchar,uwidechar }
  118. type
  119. tbasedef=(bvoid,bchar,bint,bbool);
  120. const
  121. basedeftbl:array[tbasetype] of tbasedef =
  122. (bvoid,
  123. bint,bint,bint,bint,
  124. bint,bint,bint,bint,
  125. bbool,bbool,bbool,bbool,
  126. bchar,bchar,bint);
  127. basedefconvertsimplicit : array[tbasedef,tbasedef] of tconverttype =
  128. { void, char, int, bool }
  129. ((tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible),
  130. (tc_not_possible,tc_char_2_char,tc_not_possible,tc_not_possible),
  131. (tc_not_possible,tc_not_possible,tc_int_2_int,tc_not_possible),
  132. (tc_not_possible,tc_not_possible,tc_not_possible,tc_bool_2_bool));
  133. basedefconvertsexplicit : array[tbasedef,tbasedef] of tconverttype =
  134. { void, char, int, bool }
  135. ((tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible),
  136. (tc_not_possible,tc_char_2_char,tc_int_2_int,tc_int_2_bool),
  137. (tc_not_possible,tc_int_2_int,tc_int_2_int,tc_int_2_bool),
  138. (tc_not_possible,tc_bool_2_int,tc_bool_2_int,tc_bool_2_bool));
  139. var
  140. subeq,eq : tequaltype;
  141. hd1,hd2 : tdef;
  142. hct : tconverttype;
  143. hobjdef : tobjectdef;
  144. hpd : tprocdef;
  145. begin
  146. eq:=te_incompatible;
  147. doconv:=tc_not_possible;
  148. { safety check }
  149. if not(assigned(def_from) and assigned(def_to)) then
  150. begin
  151. compare_defs_ext:=te_incompatible;
  152. exit;
  153. end;
  154. { same def? then we've an exact match }
  155. if def_from=def_to then
  156. begin
  157. doconv:=tc_equal;
  158. compare_defs_ext:=te_exact;
  159. exit;
  160. end;
  161. { undefined def? then mark it as equal }
  162. if (def_from.deftype=undefineddef) or
  163. (def_to.deftype=undefineddef) then
  164. begin
  165. doconv:=tc_equal;
  166. compare_defs_ext:=te_equal;
  167. exit;
  168. end;
  169. { undefined def? then mark it as equal }
  170. if (def_from.deftype=undefineddef) or
  171. (def_to.deftype=undefineddef) then
  172. begin
  173. doconv:=tc_equal;
  174. compare_defs_ext:=te_equal;
  175. exit;
  176. end;
  177. { we walk the wanted (def_to) types and check then the def_from
  178. types if there is a conversion possible }
  179. case def_to.deftype of
  180. orddef :
  181. begin
  182. case def_from.deftype of
  183. orddef :
  184. begin
  185. if (torddef(def_from).typ=torddef(def_to).typ) then
  186. begin
  187. case torddef(def_from).typ of
  188. uchar,uwidechar,
  189. u8bit,u16bit,u32bit,u64bit,
  190. s8bit,s16bit,s32bit,s64bit:
  191. begin
  192. if (torddef(def_from).low=torddef(def_to).low) and
  193. (torddef(def_from).high=torddef(def_to).high) then
  194. eq:=te_equal
  195. else
  196. begin
  197. doconv:=tc_int_2_int;
  198. eq:=te_convert_l1;
  199. end;
  200. end;
  201. uvoid,
  202. bool8bit,bool16bit,bool32bit,bool64bit:
  203. eq:=te_equal;
  204. else
  205. internalerror(200210061);
  206. end;
  207. end
  208. else
  209. begin
  210. if cdo_explicit in cdoptions then
  211. doconv:=basedefconvertsexplicit[basedeftbl[torddef(def_from).typ],basedeftbl[torddef(def_to).typ]]
  212. else
  213. doconv:=basedefconvertsimplicit[basedeftbl[torddef(def_from).typ],basedeftbl[torddef(def_to).typ]];
  214. if (doconv=tc_not_possible) then
  215. eq:=te_incompatible
  216. else
  217. { "punish" bad type conversions :) (JM) }
  218. if (not is_in_limit(def_from,def_to)) and
  219. (def_from.size > def_to.size) then
  220. eq:=te_convert_l3
  221. else
  222. eq:=te_convert_l1;
  223. end;
  224. end;
  225. enumdef :
  226. begin
  227. { needed for char(enum) }
  228. if cdo_explicit in cdoptions then
  229. begin
  230. doconv:=tc_int_2_int;
  231. eq:=te_convert_l1;
  232. end;
  233. end;
  234. floatdef :
  235. begin
  236. if is_currency(def_to) then
  237. begin
  238. doconv:=tc_real_2_currency;
  239. eq:=te_convert_l2;
  240. end;
  241. end;
  242. classrefdef,
  243. procvardef,
  244. pointerdef :
  245. begin
  246. if cdo_explicit in cdoptions then
  247. begin
  248. eq:=te_convert_l1;
  249. if (fromtreetype=niln) then
  250. begin
  251. { will be handled by the constant folding }
  252. doconv:=tc_equal;
  253. end
  254. else
  255. doconv:=tc_int_2_int;
  256. end;
  257. end;
  258. arraydef :
  259. begin
  260. if (m_mac in current_settings.modeswitches) and
  261. (fromtreetype=stringconstn) then
  262. begin
  263. eq:=te_convert_l3;
  264. doconv:=tc_cstring_2_int;
  265. end;
  266. end;
  267. end;
  268. end;
  269. stringdef :
  270. begin
  271. case def_from.deftype of
  272. stringdef :
  273. begin
  274. { Constant string }
  275. if (fromtreetype=stringconstn) then
  276. begin
  277. if (tstringdef(def_from).string_typ=tstringdef(def_to).string_typ) then
  278. eq:=te_equal
  279. else
  280. begin
  281. doconv:=tc_string_2_string;
  282. { Don't prefer conversions from widestring to a
  283. normal string as we can loose information }
  284. if tstringdef(def_from).string_typ=st_widestring then
  285. eq:=te_convert_l3
  286. else if tstringdef(def_to).string_typ=st_widestring then
  287. eq:=te_convert_l2
  288. else
  289. eq:=te_equal;
  290. end;
  291. end
  292. else
  293. { Same string type, for shortstrings also the length must match }
  294. if (tstringdef(def_from).string_typ=tstringdef(def_to).string_typ) and
  295. ((tstringdef(def_from).string_typ<>st_shortstring) or
  296. (tstringdef(def_from).len=tstringdef(def_to).len)) then
  297. eq:=te_equal
  298. else
  299. begin
  300. doconv:=tc_string_2_string;
  301. case tstringdef(def_from).string_typ of
  302. st_widestring :
  303. begin
  304. { Prefer conversions to ansistring }
  305. if tstringdef(def_to).string_typ=st_ansistring then
  306. eq:=te_convert_l2
  307. else
  308. eq:=te_convert_l3;
  309. end;
  310. st_shortstring :
  311. begin
  312. { Prefer shortstrings of different length or conversions
  313. from shortstring to ansistring }
  314. if (tstringdef(def_to).string_typ=st_shortstring) then
  315. eq:=te_convert_l1
  316. else if tstringdef(def_to).string_typ=st_ansistring then
  317. eq:=te_convert_l2
  318. else
  319. eq:=te_convert_l3;
  320. end;
  321. st_ansistring :
  322. begin
  323. { Prefer conversion to widestrings }
  324. if (tstringdef(def_to).string_typ=st_widestring) then
  325. eq:=te_convert_l2
  326. else
  327. eq:=te_convert_l3;
  328. end;
  329. end;
  330. end;
  331. end;
  332. orddef :
  333. begin
  334. { char to string}
  335. if is_char(def_from) or
  336. is_widechar(def_from) then
  337. begin
  338. doconv:=tc_char_2_string;
  339. eq:=te_convert_l1;
  340. end;
  341. if (m_mac in current_settings.modeswitches) and
  342. is_integer(def_from) and
  343. (def_from.size = 4) then
  344. begin
  345. doconv:=tc_int_2_string;
  346. eq:=te_convert_l3
  347. end;
  348. end;
  349. arraydef :
  350. begin
  351. { array of char to string, the length check is done by the firstpass of this node }
  352. if is_chararray(def_from) or is_open_chararray(def_from) then
  353. begin
  354. { "Untyped" stringconstn is an array of char }
  355. if fromtreetype=stringconstn then
  356. begin
  357. doconv:=tc_string_2_string;
  358. { prefered string type depends on the $H switch }
  359. if not(cs_ansistrings in current_settings.localswitches) and
  360. (tstringdef(def_to).string_typ=st_shortstring) then
  361. eq:=te_equal
  362. else if (cs_ansistrings in current_settings.localswitches) and
  363. (tstringdef(def_to).string_typ=st_ansistring) then
  364. eq:=te_equal
  365. else if tstringdef(def_to).string_typ=st_widestring then
  366. eq:=te_convert_l3
  367. else
  368. eq:=te_convert_l1;
  369. end
  370. else
  371. begin
  372. doconv:=tc_chararray_2_string;
  373. if is_open_array(def_from) then
  374. begin
  375. if is_ansistring(def_to) then
  376. eq:=te_convert_l1
  377. else if is_widestring(def_to) then
  378. eq:=te_convert_l3
  379. else
  380. eq:=te_convert_l2;
  381. end
  382. else
  383. begin
  384. if is_shortstring(def_to) then
  385. begin
  386. { Only compatible with arrays that fit
  387. smaller than 255 chars }
  388. if (def_from.size <= 255) then
  389. eq:=te_convert_l1;
  390. end
  391. else if is_ansistring(def_to) then
  392. begin
  393. if (def_from.size > 255) then
  394. eq:=te_convert_l1
  395. else
  396. eq:=te_convert_l2;
  397. end
  398. else if is_widestring(def_to) then
  399. eq:=te_convert_l3
  400. else
  401. eq:=te_convert_l2;
  402. end;
  403. end;
  404. end
  405. else
  406. { array of widechar to string, the length check is done by the firstpass of this node }
  407. if is_widechararray(def_from) or is_open_widechararray(def_from) then
  408. begin
  409. doconv:=tc_chararray_2_string;
  410. if is_widestring(def_to) then
  411. eq:=te_convert_l1
  412. else
  413. { size of widechar array is double due the sizeof a widechar }
  414. if not(is_shortstring(def_to) and (def_from.size>255*sizeof(widechar))) then
  415. eq:=te_convert_l3
  416. else
  417. eq:=te_convert_l2;
  418. end;
  419. end;
  420. pointerdef :
  421. begin
  422. { pchar can be assigned to short/ansistrings,
  423. but not in tp7 compatible mode }
  424. if not(m_tp7 in current_settings.modeswitches) then
  425. begin
  426. if is_pchar(def_from) then
  427. begin
  428. doconv:=tc_pchar_2_string;
  429. { prefer ansistrings because pchars can overflow shortstrings, }
  430. { but only if ansistrings are the default (JM) }
  431. if (is_shortstring(def_to) and
  432. not(cs_ansistrings in current_settings.localswitches)) or
  433. (is_ansistring(def_to) and
  434. (cs_ansistrings in current_settings.localswitches)) then
  435. eq:=te_convert_l1
  436. else
  437. eq:=te_convert_l2;
  438. end
  439. else if is_pwidechar(def_from) then
  440. begin
  441. doconv:=tc_pwchar_2_string;
  442. if is_widestring(def_to) then
  443. eq:=te_convert_l1
  444. else
  445. eq:=te_convert_l3;
  446. end;
  447. end;
  448. end;
  449. end;
  450. end;
  451. floatdef :
  452. begin
  453. case def_from.deftype of
  454. orddef :
  455. begin { ordinal to real }
  456. { only for implicit and internal typecasts in tp/delphi }
  457. if (([cdo_explicit,cdo_internal] * cdoptions <> [cdo_explicit]) or
  458. ([m_tp7,m_delphi] * current_settings.modeswitches = [])) and
  459. (is_integer(def_from) or
  460. (is_currency(def_from) and
  461. (s64currencytype.deftype = floatdef))) then
  462. begin
  463. doconv:=tc_int_2_real;
  464. eq:=te_convert_l1;
  465. end
  466. else if is_currency(def_from)
  467. { and (s64currencytype.deftype = orddef)) } then
  468. begin
  469. { prefer conversion to orddef in this case, unless }
  470. { the orddef < currency (then it will get convert l3, }
  471. { and conversion to float is favoured) }
  472. doconv:=tc_int_2_real;
  473. eq:=te_convert_l2;
  474. end;
  475. end;
  476. floatdef :
  477. begin
  478. if tfloatdef(def_from).typ=tfloatdef(def_to).typ then
  479. eq:=te_equal
  480. else
  481. begin
  482. if (fromtreetype=realconstn) or
  483. not((cdo_explicit in cdoptions) and
  484. (m_delphi in current_settings.modeswitches)) then
  485. begin
  486. doconv:=tc_real_2_real;
  487. { do we loose precision? }
  488. if def_to.size<def_from.size then
  489. eq:=te_convert_l2
  490. else
  491. eq:=te_convert_l1;
  492. end;
  493. end;
  494. end;
  495. end;
  496. end;
  497. enumdef :
  498. begin
  499. case def_from.deftype of
  500. enumdef :
  501. begin
  502. if cdo_explicit in cdoptions then
  503. begin
  504. eq:=te_convert_l1;
  505. doconv:=tc_int_2_int;
  506. end
  507. else
  508. begin
  509. hd1:=def_from;
  510. while assigned(tenumdef(hd1).basedef) do
  511. hd1:=tenumdef(hd1).basedef;
  512. hd2:=def_to;
  513. while assigned(tenumdef(hd2).basedef) do
  514. hd2:=tenumdef(hd2).basedef;
  515. if (hd1=hd2) then
  516. begin
  517. eq:=te_convert_l1;
  518. { because of packenum they can have different sizes! (JM) }
  519. doconv:=tc_int_2_int;
  520. end
  521. else
  522. begin
  523. { assignment of an enum symbol to an unique type? }
  524. if (fromtreetype=ordconstn) and
  525. (tenumsym(tenumdef(hd1).firstenum)=tenumsym(tenumdef(hd2).firstenum)) then
  526. begin
  527. { because of packenum they can have different sizes! (JM) }
  528. eq:=te_convert_l1;
  529. doconv:=tc_int_2_int;
  530. end;
  531. end;
  532. end;
  533. end;
  534. orddef :
  535. begin
  536. if cdo_explicit in cdoptions then
  537. begin
  538. eq:=te_convert_l1;
  539. doconv:=tc_int_2_int;
  540. end;
  541. end;
  542. variantdef :
  543. begin
  544. eq:=te_convert_l1;
  545. doconv:=tc_variant_2_enum;
  546. end;
  547. pointerdef :
  548. begin
  549. { ugly, but delphi allows it }
  550. if (cdo_explicit in cdoptions) and
  551. (m_delphi in current_settings.modeswitches) and
  552. (eq=te_incompatible) then
  553. begin
  554. doconv:=tc_int_2_int;
  555. eq:=te_convert_l1;
  556. end;
  557. end;
  558. end;
  559. end;
  560. arraydef :
  561. begin
  562. { open array is also compatible with a single element of its base type.
  563. the extra check for deftyp is needed because equal defs can also return
  564. true if the def types are not the same, for example with dynarray to pointer. }
  565. if is_open_array(def_to) and
  566. (def_from.deftype=tarraydef(def_to).elementdef.deftype) and
  567. equal_defs(def_from,tarraydef(def_to).elementdef) then
  568. begin
  569. doconv:=tc_equal;
  570. eq:=te_convert_l1;
  571. end
  572. else
  573. begin
  574. case def_from.deftype of
  575. arraydef :
  576. begin
  577. { from/to packed array -- packed chararrays are }
  578. { strings in ISO Pascal (at least if the lower bound }
  579. { is 1, but GPC makes all equal-length chararrays }
  580. { compatible), so treat those the same as regular }
  581. { char arrays }
  582. if (is_packed_array(def_from) and
  583. not is_chararray(def_from) and
  584. not is_widechararray(def_from)) xor
  585. (is_packed_array(def_to) and
  586. not is_chararray(def_to) and
  587. not is_widechararray(def_to)) then
  588. { both must be packed }
  589. begin
  590. compare_defs_ext:=te_incompatible;
  591. exit;
  592. end
  593. { to dynamic array }
  594. else if is_dynamic_array(def_to) then
  595. begin
  596. if equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) then
  597. begin
  598. { dynamic array -> dynamic array }
  599. if is_dynamic_array(def_from) then
  600. eq:=te_equal
  601. { fpc modes only: array -> dyn. array }
  602. else if (current_settings.modeswitches*[m_objfpc,m_fpc]<>[]) and
  603. not(is_special_array(def_from)) and
  604. is_zero_based_array(def_from) then
  605. begin
  606. eq:=te_convert_l2;
  607. doconv:=tc_array_2_dynarray;
  608. end;
  609. end
  610. end
  611. else
  612. { to open array }
  613. if is_open_array(def_to) then
  614. begin
  615. { array constructor -> open array }
  616. if is_array_constructor(def_from) then
  617. begin
  618. if is_void(tarraydef(def_from).elementdef) then
  619. begin
  620. doconv:=tc_equal;
  621. eq:=te_convert_l1;
  622. end
  623. else
  624. begin
  625. subeq:=compare_defs_ext(tarraydef(def_from).elementdef,
  626. tarraydef(def_to).elementdef,
  627. arrayconstructorn,hct,hpd,[cdo_check_operator]);
  628. if (subeq>=te_equal) then
  629. begin
  630. doconv:=tc_equal;
  631. eq:=te_convert_l1;
  632. end
  633. else
  634. if (subeq>te_incompatible) then
  635. begin
  636. doconv:=hct;
  637. eq:=te_convert_l2;
  638. end;
  639. end;
  640. end
  641. else
  642. { dynamic array -> open array }
  643. if is_dynamic_array(def_from) and
  644. equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) then
  645. begin
  646. doconv:=tc_dynarray_2_openarray;
  647. eq:=te_convert_l2;
  648. end
  649. else
  650. { open array -> open array }
  651. if is_open_array(def_from) and
  652. equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) then
  653. eq:=te_equal
  654. else
  655. { array -> open array }
  656. if not(cdo_parameter in cdoptions) and
  657. equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) then
  658. eq:=te_equal;
  659. end
  660. else
  661. { to array of const }
  662. if is_array_of_const(def_to) then
  663. begin
  664. if is_array_of_const(def_from) or
  665. is_array_constructor(def_from) then
  666. begin
  667. eq:=te_equal;
  668. end
  669. else
  670. { array of tvarrec -> array of const }
  671. if equal_defs(tarraydef(def_to).elementdef,tarraydef(def_from).elementdef) then
  672. begin
  673. doconv:=tc_equal;
  674. eq:=te_convert_l1;
  675. end;
  676. end
  677. else
  678. { to array of char, from "Untyped" stringconstn (array of char) }
  679. if (fromtreetype=stringconstn) and
  680. (is_chararray(def_to) or
  681. is_widechararray(def_to)) then
  682. begin
  683. eq:=te_convert_l1;
  684. doconv:=tc_string_2_chararray;
  685. end
  686. else
  687. { other arrays }
  688. begin
  689. { open array -> array }
  690. if not(cdo_parameter in cdoptions) and
  691. is_open_array(def_from) and
  692. equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) then
  693. begin
  694. eq:=te_equal
  695. end
  696. else
  697. { array -> array }
  698. if not(m_tp7 in current_settings.modeswitches) and
  699. not(m_delphi in current_settings.modeswitches) and
  700. (tarraydef(def_from).lowrange=tarraydef(def_to).lowrange) and
  701. (tarraydef(def_from).highrange=tarraydef(def_to).highrange) and
  702. equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) and
  703. equal_defs(tarraydef(def_from).rangedef,tarraydef(def_to).rangedef) then
  704. begin
  705. eq:=te_equal
  706. end;
  707. end;
  708. end;
  709. pointerdef :
  710. begin
  711. { nil and voidpointers are compatible with dyn. arrays }
  712. if is_dynamic_array(def_to) and
  713. ((fromtreetype=niln) or
  714. is_voidpointer(def_from)) then
  715. begin
  716. doconv:=tc_equal;
  717. eq:=te_convert_l1;
  718. end
  719. else
  720. if is_zero_based_array(def_to) and
  721. equal_defs(tpointerdef(def_from).pointeddef,tarraydef(def_to).elementdef) then
  722. begin
  723. doconv:=tc_pointer_2_array;
  724. eq:=te_convert_l1;
  725. end;
  726. end;
  727. stringdef :
  728. begin
  729. { string to char array }
  730. if (not is_special_array(def_to)) and
  731. (is_char(tarraydef(def_to).elementdef)or
  732. is_widechar(tarraydef(def_to).elementdef)) then
  733. begin
  734. doconv:=tc_string_2_chararray;
  735. eq:=te_convert_l1;
  736. end;
  737. end;
  738. orddef:
  739. begin
  740. if is_chararray(def_to) and
  741. is_char(def_from) then
  742. begin
  743. doconv:=tc_char_2_chararray;
  744. eq:=te_convert_l2;
  745. end;
  746. end;
  747. recorddef :
  748. begin
  749. { tvarrec -> array of const }
  750. if is_array_of_const(def_to) and
  751. equal_defs(def_from,tarraydef(def_to).elementdef) then
  752. begin
  753. doconv:=tc_equal;
  754. eq:=te_convert_l1;
  755. end;
  756. end;
  757. variantdef :
  758. begin
  759. if is_dynamic_array(def_to) then
  760. begin
  761. doconv:=tc_variant_2_dynarray;
  762. eq:=te_convert_l1;
  763. end;
  764. end;
  765. end;
  766. end;
  767. end;
  768. variantdef :
  769. begin
  770. if (cdo_allow_variant in cdoptions) then
  771. begin
  772. case def_from.deftype of
  773. enumdef :
  774. begin
  775. doconv:=tc_enum_2_variant;
  776. eq:=te_convert_l1;
  777. end;
  778. arraydef :
  779. begin
  780. if is_dynamic_array(def_from) then
  781. begin
  782. doconv:=tc_dynarray_2_variant;
  783. eq:=te_convert_l1;
  784. end;
  785. end;
  786. objectdef :
  787. begin
  788. if is_interface(def_from) then
  789. begin
  790. doconv:=tc_interface_2_variant;
  791. eq:=te_convert_l1;
  792. end;
  793. end;
  794. variantdef :
  795. begin
  796. { doing this in the compiler avoids a lot of unncessary
  797. copying }
  798. if (tvariantdef(def_from).varianttype=vt_olevariant) and
  799. (tvariantdef(def_to).varianttype=vt_normalvariant) then
  800. begin
  801. doconv:=tc_equal;
  802. eq:=te_convert_l1;
  803. end;
  804. end;
  805. end;
  806. end;
  807. end;
  808. pointerdef :
  809. begin
  810. case def_from.deftype of
  811. stringdef :
  812. begin
  813. { string constant (which can be part of array constructor)
  814. to zero terminated string constant }
  815. if (fromtreetype in [arrayconstructorn,stringconstn]) and
  816. (is_pchar(def_to) or is_pwidechar(def_to)) then
  817. begin
  818. doconv:=tc_cstring_2_pchar;
  819. eq:=te_convert_l2;
  820. end
  821. else
  822. if cdo_explicit in cdoptions then
  823. begin
  824. { pchar(ansistring) }
  825. if is_pchar(def_to) and
  826. is_ansistring(def_from) then
  827. begin
  828. doconv:=tc_ansistring_2_pchar;
  829. eq:=te_convert_l1;
  830. end
  831. else
  832. { pwidechar(widestring) }
  833. if is_pwidechar(def_to) and
  834. is_widestring(def_from) then
  835. begin
  836. doconv:=tc_ansistring_2_pchar;
  837. eq:=te_convert_l1;
  838. end;
  839. end;
  840. end;
  841. orddef :
  842. begin
  843. { char constant to zero terminated string constant }
  844. if (fromtreetype=ordconstn) then
  845. begin
  846. if (is_char(def_from) or is_widechar(def_from)) and
  847. (is_pchar(def_to) or is_pwidechar(def_to)) then
  848. begin
  849. doconv:=tc_cchar_2_pchar;
  850. eq:=te_convert_l1;
  851. end
  852. else
  853. if (m_delphi in current_settings.modeswitches) and is_integer(def_from) then
  854. begin
  855. doconv:=tc_cord_2_pointer;
  856. eq:=te_convert_l2;
  857. end;
  858. end;
  859. { delphi compatible, allow explicit typecasts from
  860. ordinals to pointer.
  861. It is also used by the compiler internally for inc(pointer,ordinal) }
  862. if (eq=te_incompatible) and
  863. not is_void(def_from) and
  864. (
  865. (
  866. (m_delphi in current_settings.modeswitches) and
  867. (cdo_explicit in cdoptions)
  868. ) or
  869. (cdo_internal in cdoptions)
  870. ) then
  871. begin
  872. doconv:=tc_int_2_int;
  873. eq:=te_convert_l1;
  874. end;
  875. end;
  876. arraydef :
  877. begin
  878. { string constant (which can be part of array constructor)
  879. to zero terminated string constant }
  880. if (fromtreetype in [arrayconstructorn,stringconstn]) and
  881. (is_pchar(def_to) or is_pwidechar(def_to)) then
  882. begin
  883. doconv:=tc_cstring_2_pchar;
  884. eq:=te_convert_l2;
  885. end
  886. else
  887. { chararray to pointer }
  888. if (is_zero_based_array(def_from) or
  889. is_open_array(def_from)) and
  890. equal_defs(tarraydef(def_from).elementdef,tpointerdef(def_to).pointeddef) then
  891. begin
  892. doconv:=tc_array_2_pointer;
  893. { don't prefer the pchar overload when a constant
  894. string was passed }
  895. if fromtreetype=stringconstn then
  896. eq:=te_convert_l2
  897. else
  898. eq:=te_convert_l1;
  899. end
  900. else
  901. { dynamic array to pointer, delphi only }
  902. if (m_delphi in current_settings.modeswitches) and
  903. is_dynamic_array(def_from) then
  904. begin
  905. eq:=te_equal;
  906. end;
  907. end;
  908. pointerdef :
  909. begin
  910. { check for far pointers }
  911. if (tpointerdef(def_from).is_far<>tpointerdef(def_to).is_far) then
  912. begin
  913. eq:=te_incompatible;
  914. end
  915. else
  916. { the types can be forward type, handle before normal type check !! }
  917. if assigned(def_to.typesym) and
  918. (tpointerdef(def_to).pointeddef.deftype=forwarddef) then
  919. begin
  920. if (def_from.typesym=def_to.typesym) then
  921. eq:=te_equal
  922. end
  923. else
  924. { same types }
  925. if equal_defs(tpointerdef(def_from).pointeddef,tpointerdef(def_to).pointeddef) then
  926. begin
  927. eq:=te_equal
  928. end
  929. else
  930. { child class pointer can be assigned to anchestor pointers }
  931. if (
  932. (tpointerdef(def_from).pointeddef.deftype=objectdef) and
  933. (tpointerdef(def_to).pointeddef.deftype=objectdef) and
  934. tobjectdef(tpointerdef(def_from).pointeddef).is_related(
  935. tobjectdef(tpointerdef(def_to).pointeddef))
  936. ) then
  937. begin
  938. doconv:=tc_equal;
  939. eq:=te_convert_l1;
  940. end
  941. else
  942. { all pointers can be assigned to void-pointer }
  943. if is_void(tpointerdef(def_to).pointeddef) then
  944. begin
  945. doconv:=tc_equal;
  946. { give pwidechar,pchar a penalty so it prefers
  947. conversion to ansistring }
  948. if is_pchar(def_from) or
  949. is_pwidechar(def_from) then
  950. eq:=te_convert_l2
  951. else
  952. eq:=te_convert_l1;
  953. end
  954. else
  955. { all pointers can be assigned from void-pointer }
  956. if is_void(tpointerdef(def_from).pointeddef) or
  957. { all pointers can be assigned from void-pointer or formaldef pointer, check
  958. tw3777.pp if you change this }
  959. (tpointerdef(def_from).pointeddef.deftype=formaldef) then
  960. begin
  961. doconv:=tc_equal;
  962. { give pwidechar a penalty so it prefers
  963. conversion to pchar }
  964. if is_pwidechar(def_to) then
  965. eq:=te_convert_l2
  966. else
  967. eq:=te_convert_l1;
  968. end;
  969. end;
  970. procvardef :
  971. begin
  972. { procedure variable can be assigned to an void pointer,
  973. this not allowed for methodpointers }
  974. if (is_void(tpointerdef(def_to).pointeddef) or
  975. (m_mac_procvar in current_settings.modeswitches)) and
  976. tprocvardef(def_from).is_addressonly then
  977. begin
  978. doconv:=tc_equal;
  979. eq:=te_convert_l1;
  980. end;
  981. end;
  982. procdef :
  983. begin
  984. { procedure variable can be assigned to an void pointer,
  985. this not allowed for methodpointers }
  986. if (m_mac_procvar in current_settings.modeswitches) and
  987. tprocdef(def_from).is_addressonly then
  988. begin
  989. doconv:=tc_proc_2_procvar;
  990. eq:=te_convert_l2;
  991. end;
  992. end;
  993. classrefdef,
  994. objectdef :
  995. begin
  996. { class types and class reference type
  997. can be assigned to void pointers, but it is less
  998. preferred than assigning to a related objectdef }
  999. if (
  1000. is_class_or_interface(def_from) or
  1001. (def_from.deftype=classrefdef)
  1002. ) and
  1003. (tpointerdef(def_to).pointeddef.deftype=orddef) and
  1004. (torddef(tpointerdef(def_to).pointeddef).typ=uvoid) then
  1005. begin
  1006. doconv:=tc_equal;
  1007. eq:=te_convert_l2;
  1008. end;
  1009. end;
  1010. end;
  1011. end;
  1012. setdef :
  1013. begin
  1014. case def_from.deftype of
  1015. setdef :
  1016. begin
  1017. if assigned(tsetdef(def_from).elementdef) and
  1018. assigned(tsetdef(def_to).elementdef) then
  1019. begin
  1020. { sets with the same element base type are equal }
  1021. if is_subequal(tsetdef(def_from).elementdef,tsetdef(def_to).elementdef) then
  1022. eq:=te_equal;
  1023. end
  1024. else
  1025. { empty set is compatible with everything }
  1026. eq:=te_equal;
  1027. end;
  1028. arraydef :
  1029. begin
  1030. { automatic arrayconstructor -> set conversion }
  1031. if is_array_constructor(def_from) then
  1032. begin
  1033. doconv:=tc_arrayconstructor_2_set;
  1034. eq:=te_convert_l1;
  1035. end;
  1036. end;
  1037. end;
  1038. end;
  1039. procvardef :
  1040. begin
  1041. case def_from.deftype of
  1042. procdef :
  1043. begin
  1044. { proc -> procvar }
  1045. if (m_tp_procvar in current_settings.modeswitches) or
  1046. (m_mac_procvar in current_settings.modeswitches) then
  1047. begin
  1048. subeq:=proc_to_procvar_equal(tprocdef(def_from),tprocvardef(def_to));
  1049. if subeq>te_incompatible then
  1050. begin
  1051. doconv:=tc_proc_2_procvar;
  1052. eq:=te_convert_l1;
  1053. end;
  1054. end;
  1055. end;
  1056. procvardef :
  1057. begin
  1058. { procvar -> procvar }
  1059. eq:=proc_to_procvar_equal(tprocvardef(def_from),tprocvardef(def_to));
  1060. end;
  1061. pointerdef :
  1062. begin
  1063. { nil is compatible with procvars }
  1064. if (fromtreetype=niln) then
  1065. begin
  1066. doconv:=tc_equal;
  1067. eq:=te_convert_l1;
  1068. end
  1069. else
  1070. { for example delphi allows the assignement from pointers }
  1071. { to procedure variables }
  1072. if (m_pointer_2_procedure in current_settings.modeswitches) and
  1073. is_void(tpointerdef(def_from).pointeddef) and
  1074. tprocvardef(def_to).is_addressonly then
  1075. begin
  1076. doconv:=tc_equal;
  1077. eq:=te_convert_l1;
  1078. end;
  1079. end;
  1080. end;
  1081. end;
  1082. objectdef :
  1083. begin
  1084. { object pascal objects }
  1085. if (def_from.deftype=objectdef) and
  1086. (tobjectdef(def_from).is_related(tobjectdef(def_to))) then
  1087. begin
  1088. doconv:=tc_equal;
  1089. eq:=te_convert_l1;
  1090. end
  1091. else
  1092. { Class/interface specific }
  1093. if is_class_or_interface(def_to) then
  1094. begin
  1095. { void pointer also for delphi mode }
  1096. if (m_delphi in current_settings.modeswitches) and
  1097. is_voidpointer(def_from) then
  1098. begin
  1099. doconv:=tc_equal;
  1100. { prefer pointer-pointer assignments }
  1101. eq:=te_convert_l2;
  1102. end
  1103. else
  1104. { nil is compatible with class instances and interfaces }
  1105. if (fromtreetype=niln) then
  1106. begin
  1107. doconv:=tc_equal;
  1108. eq:=te_convert_l1;
  1109. end
  1110. { classes can be assigned to interfaces }
  1111. else if is_interface(def_to) and
  1112. is_class(def_from) and
  1113. assigned(tobjectdef(def_from).ImplementedInterfaces) then
  1114. begin
  1115. { we've to search in parent classes as well }
  1116. hobjdef:=tobjectdef(def_from);
  1117. while assigned(hobjdef) do
  1118. begin
  1119. if hobjdef.find_implemented_interface(tobjectdef(def_to))<>nil then
  1120. begin
  1121. doconv:=tc_class_2_intf;
  1122. { don't prefer this over objectdef->objectdef }
  1123. eq:=te_convert_l2;
  1124. break;
  1125. end;
  1126. hobjdef:=hobjdef.childof;
  1127. end;
  1128. end
  1129. { Interface 2 GUID handling }
  1130. else if (def_to=tdef(rec_tguid)) and
  1131. (fromtreetype=typen) and
  1132. is_interface(def_from) and
  1133. assigned(tobjectdef(def_from).iidguid) then
  1134. begin
  1135. eq:=te_convert_l1;
  1136. doconv:=tc_equal;
  1137. end
  1138. else if (def_from.deftype=variantdef) and is_interface(def_to) then
  1139. begin
  1140. doconv:=tc_variant_2_interface;
  1141. eq:=te_convert_l2;
  1142. end
  1143. { ugly, but delphi allows it }
  1144. else if (eq=te_incompatible) and
  1145. (def_from.deftype=orddef) and
  1146. (m_delphi in current_settings.modeswitches) and
  1147. (cdo_explicit in cdoptions) then
  1148. begin
  1149. doconv:=tc_int_2_int;
  1150. eq:=te_convert_l1;
  1151. end;
  1152. end;
  1153. end;
  1154. classrefdef :
  1155. begin
  1156. { similar to pointerdef wrt forwards }
  1157. if assigned(def_to.typesym) and
  1158. (tclassrefdef(def_to).pointeddef.deftype=forwarddef) then
  1159. begin
  1160. if (def_from.typesym=def_to.typesym) then
  1161. eq:=te_equal;
  1162. end
  1163. else
  1164. { class reference types }
  1165. if (def_from.deftype=classrefdef) then
  1166. begin
  1167. if equal_defs(tclassrefdef(def_from).pointeddef,tclassrefdef(def_to).pointeddef) then
  1168. begin
  1169. eq:=te_equal;
  1170. end
  1171. else
  1172. begin
  1173. doconv:=tc_equal;
  1174. if (cdo_explicit in cdoptions) or
  1175. tobjectdef(tclassrefdef(def_from).pointeddef).is_related(
  1176. tobjectdef(tclassrefdef(def_to).pointeddef)) then
  1177. eq:=te_convert_l1;
  1178. end;
  1179. end
  1180. else
  1181. { nil is compatible with class references }
  1182. if (fromtreetype=niln) then
  1183. begin
  1184. doconv:=tc_equal;
  1185. eq:=te_convert_l1;
  1186. end;
  1187. end;
  1188. filedef :
  1189. begin
  1190. { typed files are all equal to the abstract file type
  1191. name TYPEDFILE in system.pp in is_equal in types.pas
  1192. the problem is that it sholud be also compatible to FILE
  1193. but this would leed to a problem for ASSIGN RESET and REWRITE
  1194. when trying to find the good overloaded function !!
  1195. so all file function are doubled in system.pp
  1196. this is not very beautiful !!}
  1197. if (def_from.deftype=filedef) then
  1198. begin
  1199. if (tfiledef(def_from).filetyp=tfiledef(def_to).filetyp) then
  1200. begin
  1201. if
  1202. (
  1203. (tfiledef(def_from).typedfiledef=nil) and
  1204. (tfiledef(def_to).typedfiledef=nil)
  1205. ) or
  1206. (
  1207. (tfiledef(def_from).typedfiledef<>nil) and
  1208. (tfiledef(def_to).typedfiledef<>nil) and
  1209. equal_defs(tfiledef(def_from).typedfiledef,tfiledef(def_to).typedfiledef)
  1210. ) or
  1211. (
  1212. (tfiledef(def_from).filetyp = ft_typed) and
  1213. (tfiledef(def_to).filetyp = ft_typed) and
  1214. (
  1215. (tfiledef(def_from).typedfiledef = tdef(voidtype)) or
  1216. (tfiledef(def_to).typedfiledef = tdef(voidtype))
  1217. )
  1218. ) then
  1219. begin
  1220. eq:=te_equal;
  1221. end;
  1222. end
  1223. else
  1224. if ((tfiledef(def_from).filetyp = ft_untyped) and
  1225. (tfiledef(def_to).filetyp = ft_typed)) or
  1226. ((tfiledef(def_from).filetyp = ft_typed) and
  1227. (tfiledef(def_to).filetyp = ft_untyped)) then
  1228. begin
  1229. doconv:=tc_equal;
  1230. eq:=te_convert_l1;
  1231. end;
  1232. end;
  1233. end;
  1234. recorddef :
  1235. begin
  1236. { interface -> guid }
  1237. if is_interface(def_from) and
  1238. (def_to=rec_tguid) then
  1239. begin
  1240. doconv:=tc_intf_2_guid;
  1241. eq:=te_convert_l1;
  1242. end;
  1243. end;
  1244. formaldef :
  1245. begin
  1246. doconv:=tc_equal;
  1247. if (def_from.deftype=formaldef) then
  1248. eq:=te_equal
  1249. else
  1250. { Just about everything can be converted to a formaldef...}
  1251. if not (def_from.deftype in [abstractdef,errordef]) then
  1252. eq:=te_convert_l2;
  1253. end;
  1254. end;
  1255. { if we didn't find an appropriate type conversion yet
  1256. then we search also the := operator }
  1257. if (eq=te_incompatible) and
  1258. (
  1259. { Check for variants? }
  1260. (
  1261. (cdo_allow_variant in cdoptions) and
  1262. ((def_from.deftype=variantdef) or (def_to.deftype=variantdef))
  1263. ) or
  1264. { Check for operators? }
  1265. (
  1266. (cdo_check_operator in cdoptions) and
  1267. ((def_from.deftype in [objectdef,recorddef,arraydef,stringdef,variantdef]) or
  1268. (def_to.deftype in [objectdef,recorddef,arraydef,stringdef,variantdef]))
  1269. )
  1270. ) then
  1271. begin
  1272. operatorpd:=search_assignment_operator(def_from,def_to);
  1273. if assigned(operatorpd) then
  1274. eq:=te_convert_operator;
  1275. end;
  1276. { update convtype for te_equal when it is not yet set }
  1277. if (eq=te_equal) and
  1278. (doconv=tc_not_possible) then
  1279. doconv:=tc_equal;
  1280. compare_defs_ext:=eq;
  1281. end;
  1282. function equal_defs(def_from,def_to:tdef):boolean;
  1283. var
  1284. convtyp : tconverttype;
  1285. pd : tprocdef;
  1286. begin
  1287. { Compare defs with nothingn and no explicit typecasts and
  1288. searching for overloaded operators is not needed }
  1289. equal_defs:=(compare_defs_ext(def_from,def_to,nothingn,convtyp,pd,[])>=te_equal);
  1290. end;
  1291. function compare_defs(def_from,def_to:tdef;fromtreetype:tnodetype):tequaltype;
  1292. var
  1293. doconv : tconverttype;
  1294. pd : tprocdef;
  1295. begin
  1296. compare_defs:=compare_defs_ext(def_from,def_to,fromtreetype,doconv,pd,[cdo_check_operator,cdo_allow_variant]);
  1297. end;
  1298. function is_subequal(def1, def2: tdef): boolean;
  1299. var
  1300. basedef1,basedef2 : tenumdef;
  1301. Begin
  1302. is_subequal := false;
  1303. if assigned(def1) and assigned(def2) then
  1304. Begin
  1305. if (def1.deftype = orddef) and (def2.deftype = orddef) then
  1306. Begin
  1307. { see p.47 of Turbo Pascal 7.01 manual for the separation of types }
  1308. { range checking for case statements is done with testrange }
  1309. case torddef(def1).typ of
  1310. u8bit,u16bit,u32bit,u64bit,
  1311. s8bit,s16bit,s32bit,s64bit :
  1312. is_subequal:=(torddef(def2).typ in [s64bit,u64bit,s32bit,u32bit,u8bit,s8bit,s16bit,u16bit]);
  1313. bool8bit,bool16bit,bool32bit,bool64bit :
  1314. is_subequal:=(torddef(def2).typ in [bool8bit,bool16bit,bool32bit,bool64bit]);
  1315. uchar :
  1316. is_subequal:=(torddef(def2).typ=uchar);
  1317. uwidechar :
  1318. is_subequal:=(torddef(def2).typ=uwidechar);
  1319. end;
  1320. end
  1321. else
  1322. Begin
  1323. { Check if both basedefs are equal }
  1324. if (def1.deftype=enumdef) and (def2.deftype=enumdef) then
  1325. Begin
  1326. { get both basedefs }
  1327. basedef1:=tenumdef(def1);
  1328. while assigned(basedef1.basedef) do
  1329. basedef1:=basedef1.basedef;
  1330. basedef2:=tenumdef(def2);
  1331. while assigned(basedef2.basedef) do
  1332. basedef2:=basedef2.basedef;
  1333. is_subequal:=(basedef1=basedef2);
  1334. end;
  1335. end;
  1336. end;
  1337. end;
  1338. function compare_paras(para1,para2 : TFPObjectList; acp : tcompare_paras_type; cpoptions: tcompare_paras_options):tequaltype;
  1339. var
  1340. currpara1,
  1341. currpara2 : tparavarsym;
  1342. eq,lowesteq : tequaltype;
  1343. hpd : tprocdef;
  1344. convtype : tconverttype;
  1345. cdoptions : tcompare_defs_options;
  1346. i1,i2 : byte;
  1347. begin
  1348. compare_paras:=te_incompatible;
  1349. cdoptions:=[cdo_parameter,cdo_check_operator,cdo_allow_variant];
  1350. { we need to parse the list from left-right so the
  1351. not-default parameters are checked first }
  1352. lowesteq:=high(tequaltype);
  1353. i1:=0;
  1354. i2:=0;
  1355. if cpo_ignorehidden in cpoptions then
  1356. begin
  1357. while (i1<para1.count) and
  1358. (vo_is_hidden_para in tparavarsym(para1[i1]).varoptions) do
  1359. inc(i1);
  1360. while (i2<para2.count) and
  1361. (vo_is_hidden_para in tparavarsym(para2[i2]).varoptions) do
  1362. inc(i2);
  1363. end;
  1364. while (i1<para1.count) and (i2<para2.count) do
  1365. begin
  1366. eq:=te_incompatible;
  1367. currpara1:=tparavarsym(para1[i1]);
  1368. currpara2:=tparavarsym(para2[i2]);
  1369. { Unique types must match exact }
  1370. if ((df_unique in currpara1.vardef.defoptions) or (df_unique in currpara2.vardef.defoptions)) and
  1371. (currpara1.vardef<>currpara2.vardef) then
  1372. exit;
  1373. { Handle hidden parameters separately, because self is
  1374. defined as voidpointer for methodpointers }
  1375. if (vo_is_hidden_para in currpara1.varoptions) or
  1376. (vo_is_hidden_para in currpara2.varoptions) then
  1377. begin
  1378. { both must be hidden }
  1379. if (vo_is_hidden_para in currpara1.varoptions)<>(vo_is_hidden_para in currpara2.varoptions) then
  1380. exit;
  1381. eq:=te_equal;
  1382. if not(vo_is_self in currpara1.varoptions) and
  1383. not(vo_is_self in currpara2.varoptions) then
  1384. begin
  1385. if (currpara1.varspez<>currpara2.varspez) then
  1386. exit;
  1387. eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
  1388. convtype,hpd,cdoptions);
  1389. end;
  1390. end
  1391. else
  1392. begin
  1393. case acp of
  1394. cp_value_equal_const :
  1395. begin
  1396. if (
  1397. (currpara1.varspez<>currpara2.varspez) and
  1398. ((currpara1.varspez in [vs_var,vs_out]) or
  1399. (currpara2.varspez in [vs_var,vs_out]))
  1400. ) then
  1401. exit;
  1402. eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
  1403. convtype,hpd,cdoptions);
  1404. end;
  1405. cp_all :
  1406. begin
  1407. if (currpara1.varspez<>currpara2.varspez) then
  1408. exit;
  1409. eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
  1410. convtype,hpd,cdoptions);
  1411. end;
  1412. cp_procvar :
  1413. begin
  1414. if (currpara1.varspez<>currpara2.varspez) then
  1415. exit;
  1416. eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
  1417. convtype,hpd,cdoptions);
  1418. { Parameters must be at least equal otherwise the are incompatible }
  1419. if (eq<te_equal) then
  1420. eq:=te_incompatible;
  1421. end;
  1422. else
  1423. eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
  1424. convtype,hpd,cdoptions);
  1425. end;
  1426. end;
  1427. { check type }
  1428. if eq=te_incompatible then
  1429. exit;
  1430. if eq<lowesteq then
  1431. lowesteq:=eq;
  1432. { also check default value if both have it declared }
  1433. if (cpo_comparedefaultvalue in cpoptions) and
  1434. assigned(currpara1.defaultconstsym) and
  1435. assigned(currpara2.defaultconstsym) then
  1436. begin
  1437. if not equal_constsym(tconstsym(currpara1.defaultconstsym),tconstsym(currpara2.defaultconstsym)) then
  1438. exit;
  1439. end;
  1440. inc(i1);
  1441. inc(i2);
  1442. if cpo_ignorehidden in cpoptions then
  1443. begin
  1444. while (i1<para1.count) and
  1445. (vo_is_hidden_para in tparavarsym(para1[i1]).varoptions) do
  1446. inc(i1);
  1447. while (i2<para2.count) and
  1448. (vo_is_hidden_para in tparavarsym(para2[i2]).varoptions) do
  1449. inc(i2);
  1450. end;
  1451. end;
  1452. { when both lists are empty then the parameters are equal. Also
  1453. when one list is empty and the other has a parameter with default
  1454. value assigned then the parameters are also equal }
  1455. if ((i1>=para1.count) and (i2>=para2.count)) or
  1456. ((cpo_allowdefaults in cpoptions) and
  1457. (((i1<para1.count) and assigned(tparavarsym(para1[i1]).defaultconstsym)) or
  1458. ((i2<para2.count) and assigned(tparavarsym(para2[i2]).defaultconstsym)))) then
  1459. compare_paras:=lowesteq;
  1460. end;
  1461. function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef):tequaltype;
  1462. var
  1463. eq : tequaltype;
  1464. po_comp : tprocoptions;
  1465. begin
  1466. proc_to_procvar_equal:=te_incompatible;
  1467. if not(assigned(def1)) or not(assigned(def2)) then
  1468. exit;
  1469. { check for method pointer }
  1470. if (def1.is_methodpointer xor def2.is_methodpointer) or
  1471. (def1.is_addressonly xor def2.is_addressonly) then
  1472. exit;
  1473. { check return value and options, methodpointer is already checked }
  1474. po_comp:=[po_staticmethod,po_interrupt,
  1475. po_iocheck,po_varargs];
  1476. if (m_delphi in current_settings.modeswitches) then
  1477. exclude(po_comp,po_varargs);
  1478. if (def1.proccalloption=def2.proccalloption) and
  1479. ((po_comp * def1.procoptions)= (po_comp * def2.procoptions)) and
  1480. equal_defs(def1.returndef,def2.returndef) then
  1481. begin
  1482. { return equal type based on the parameters, but a proc->procvar
  1483. is never exact, so map an exact match of the parameters to
  1484. te_equal }
  1485. eq:=compare_paras(def1.paras,def2.paras,cp_procvar,[]);
  1486. if eq=te_exact then
  1487. eq:=te_equal;
  1488. proc_to_procvar_equal:=eq;
  1489. end;
  1490. end;
  1491. end.