defcmp.pas 132 KB

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