defcmp.pas 134 KB

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