defcmp.pas 134 KB

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