types.pas 69 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939
  1. {
  2. $Id$
  3. Copyright (C) 1998-2000 by Florian Klaempfl
  4. This unit provides some help routines for type handling
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit types;
  19. {$i defines.inc}
  20. interface
  21. uses
  22. cclasses,
  23. cpuinfo,
  24. node,
  25. symbase,symtype,symdef,symsym;
  26. type
  27. tmmxtype = (mmxno,mmxu8bit,mmxs8bit,mmxu16bit,mmxs16bit,
  28. mmxu32bit,mmxs32bit,mmxfixed16,mmxsingle);
  29. const
  30. { true if we must never copy this parameter }
  31. never_copy_const_param : boolean = false;
  32. {*****************************************************************************
  33. Basic type functions
  34. *****************************************************************************}
  35. { returns true, if def defines an ordinal type }
  36. function is_ordinal(def : tdef) : boolean;
  37. { returns the min. value of the type }
  38. function get_min_value(def : tdef) : longint;
  39. { returns true, if def defines an ordinal type }
  40. function is_integer(def : tdef) : boolean;
  41. { true if p is a boolean }
  42. function is_boolean(def : tdef) : boolean;
  43. { true if p is a char }
  44. function is_char(def : tdef) : boolean;
  45. { true if p is a widechar }
  46. function is_widechar(def : tdef) : boolean;
  47. { true if p is a void}
  48. function is_void(def : tdef) : boolean;
  49. { true if p is a smallset def }
  50. function is_smallset(p : tdef) : boolean;
  51. { returns true, if def defines a signed data type (only for ordinal types) }
  52. function is_signed(def : tdef) : boolean;
  53. {*****************************************************************************
  54. Array helper functions
  55. *****************************************************************************}
  56. { true, if p points to a zero based (non special like open or
  57. dynamic array def, mainly this is used to see if the array
  58. is convertable to a pointer }
  59. function is_zero_based_array(p : tdef) : boolean;
  60. { true if p points to an open array def }
  61. function is_open_array(p : tdef) : boolean;
  62. { true if p points to a dynamic array def }
  63. function is_dynamic_array(p : tdef) : boolean;
  64. { true, if p points to an array of const def }
  65. function is_array_constructor(p : tdef) : boolean;
  66. { true, if p points to a variant array }
  67. function is_variant_array(p : tdef) : boolean;
  68. { true, if p points to an array of const }
  69. function is_array_of_const(p : tdef) : boolean;
  70. { true, if p points any kind of special array }
  71. function is_special_array(p : tdef) : boolean;
  72. { true if p is a char array def }
  73. function is_chararray(p : tdef) : boolean;
  74. { true if p is a wide char array def }
  75. function is_widechararray(p : tdef) : boolean;
  76. {*****************************************************************************
  77. String helper functions
  78. *****************************************************************************}
  79. { true if p points to an open string def }
  80. function is_open_string(p : tdef) : boolean;
  81. { true if p is an ansi string def }
  82. function is_ansistring(p : tdef) : boolean;
  83. { true if p is a long string def }
  84. function is_longstring(p : tdef) : boolean;
  85. { true if p is a wide string def }
  86. function is_widestring(p : tdef) : boolean;
  87. { true if p is a short string def }
  88. function is_shortstring(p : tdef) : boolean;
  89. { true if p is a pchar def }
  90. function is_pchar(p : tdef) : boolean;
  91. { true if p is a pwidechar def }
  92. function is_pwidechar(p : tdef) : boolean;
  93. { true if p is a voidpointer def }
  94. function is_voidpointer(p : tdef) : boolean;
  95. { returns true, if def uses FPU }
  96. function is_fpu(def : tdef) : boolean;
  97. { true if the return value is in EAX }
  98. function ret_in_acc(def : tdef) : boolean;
  99. { true if uses a parameter as return value }
  100. function ret_in_param(def : tdef) : boolean;
  101. { true, if def is a 64 bit int type }
  102. function is_64bitint(def : tdef) : boolean;
  103. function push_high_param(def : tdef) : boolean;
  104. { true if a parameter is too large to copy and only the address is pushed }
  105. function push_addr_param(def : tdef) : boolean;
  106. { true, if def1 and def2 are semantical the same }
  107. function is_equal(def1,def2 : tdef) : boolean;
  108. { checks for type compatibility (subgroups of type) }
  109. { used for case statements... probably missing stuff }
  110. { to use on other types }
  111. function is_subequal(def1, def2: tdef): boolean;
  112. type
  113. tconverttype = (
  114. tc_equal,
  115. tc_not_possible,
  116. tc_string_2_string,
  117. tc_char_2_string,
  118. tc_pchar_2_string,
  119. tc_cchar_2_pchar,
  120. tc_cstring_2_pchar,
  121. tc_ansistring_2_pchar,
  122. tc_string_2_chararray,
  123. tc_chararray_2_string,
  124. tc_array_2_pointer,
  125. tc_pointer_2_array,
  126. tc_int_2_int,
  127. tc_int_2_bool,
  128. tc_bool_2_bool,
  129. tc_bool_2_int,
  130. tc_real_2_real,
  131. tc_int_2_real,
  132. tc_proc_2_procvar,
  133. tc_arrayconstructor_2_set,
  134. tc_load_smallset,
  135. tc_cord_2_pointer,
  136. tc_intf_2_string,
  137. tc_intf_2_guid,
  138. tc_class_2_intf,
  139. tc_char_2_char
  140. );
  141. function assignment_overloaded(from_def,to_def : tdef) : tprocdef;
  142. { Returns:
  143. 0 - Not convertable
  144. 1 - Convertable
  145. 2 - Convertable, but not first choice }
  146. function isconvertable(def_from,def_to : tdef;
  147. var doconv : tconverttype;
  148. fromtreetype : tnodetype;
  149. explicit : boolean) : byte;
  150. { same as is_equal, but with error message if failed }
  151. function CheckTypes(def1,def2 : tdef) : boolean;
  152. function equal_constsym(sym1,sym2:tconstsym):boolean;
  153. { true, if two parameter lists are equal }
  154. { if acp is cp_none, all have to match exactly }
  155. { if acp is cp_value_equal_const call by value }
  156. { and call by const parameter are assumed as }
  157. { equal }
  158. { if acp is cp_all the var const or nothing are considered equal }
  159. type
  160. compare_type = ( cp_none, cp_value_equal_const, cp_all);
  161. function equal_paras(paralist1,paralist2 : tlinkedlist; acp : compare_type) : boolean;
  162. { true if a type can be allowed for another one
  163. in a func var }
  164. function convertable_paras(paralist1,paralist2 : tlinkedlist; acp : compare_type) : boolean;
  165. { true if a function can be assigned to a procvar }
  166. function proc_to_procvar_equal(def1:tprocdef;def2:tprocvardef) : boolean;
  167. { if l isn't in the range of def a range check error (if not explicit) is generated and
  168. the value is placed within the range }
  169. procedure testrange(def : tdef;var l : tconstexprint;explicit:boolean);
  170. { returns the range of def }
  171. procedure getrange(def : tdef;var l : longint;var h : longint);
  172. { some type helper routines for MMX support }
  173. function is_mmx_able_array(p : tdef) : boolean;
  174. { returns the mmx type }
  175. function mmx_type(p : tdef) : tmmxtype;
  176. { returns true, if sym needs an entry in the proplist of a class rtti }
  177. function needs_prop_entry(sym : tsym) : boolean;
  178. implementation
  179. uses
  180. globtype,globals,systems,tokens,verbose,
  181. symconst,symtable,nld;
  182. function needs_prop_entry(sym : tsym) : boolean;
  183. begin
  184. needs_prop_entry:=(sp_published in tsym(sym).symoptions) and
  185. (sym.typ in [propertysym,varsym]);
  186. end;
  187. function equal_constsym(sym1,sym2:tconstsym):boolean;
  188. var
  189. p1,p2,pend : pchar;
  190. begin
  191. equal_constsym:=false;
  192. if sym1.consttyp<>sym2.consttyp then
  193. exit;
  194. case sym1.consttyp of
  195. constint,
  196. constbool,
  197. constchar,
  198. constpointer,
  199. constord :
  200. equal_constsym:=(sym1.value=sym2.value);
  201. conststring,constresourcestring :
  202. begin
  203. if sym1.len=sym2.len then
  204. begin
  205. p1:=pchar(tpointerord(sym1.value));
  206. p2:=pchar(tpointerord(sym2.value));
  207. pend:=p1+sym1.len;
  208. while (p1<pend) do
  209. begin
  210. if p1^<>p2^ then
  211. break;
  212. inc(p1);
  213. inc(p2);
  214. end;
  215. if (p1=pend) then
  216. equal_constsym:=true;
  217. end;
  218. end;
  219. constreal :
  220. equal_constsym:=(pbestreal(tpointerord(sym1.value))^=pbestreal(tpointerord(sym2.value))^);
  221. constset :
  222. equal_constsym:=(pnormalset(tpointerord(sym1.value))^=pnormalset(tpointerord(sym2.value))^);
  223. constnil :
  224. equal_constsym:=true;
  225. end;
  226. end;
  227. { compare_type = ( cp_none, cp_value_equal_const, cp_all); }
  228. function equal_paras(paralist1,paralist2 : TLinkedList; acp : compare_type) : boolean;
  229. var
  230. def1,def2 : TParaItem;
  231. begin
  232. def1:=TParaItem(paralist1.first);
  233. def2:=TParaItem(paralist2.first);
  234. while (assigned(def1)) and (assigned(def2)) do
  235. begin
  236. case acp of
  237. cp_value_equal_const :
  238. begin
  239. if not(is_equal(def1.paratype.def,def2.paratype.def)) or
  240. ((def1.paratyp<>def2.paratyp) and
  241. ((def1.paratyp in [vs_var,vs_out]) or
  242. (def2.paratyp in [vs_var,vs_out])
  243. )
  244. ) then
  245. begin
  246. equal_paras:=false;
  247. exit;
  248. end;
  249. end;
  250. cp_all :
  251. begin
  252. if not(is_equal(def1.paratype.def,def2.paratype.def)) or
  253. (def1.paratyp<>def2.paratyp) then
  254. begin
  255. equal_paras:=false;
  256. exit;
  257. end;
  258. end;
  259. cp_none :
  260. begin
  261. if not(is_equal(def1.paratype.def,def2.paratype.def)) then
  262. begin
  263. equal_paras:=false;
  264. exit;
  265. end;
  266. { also check default value if both have it declared }
  267. if assigned(def1.defaultvalue) and
  268. assigned(def2.defaultvalue) then
  269. begin
  270. if not equal_constsym(tconstsym(def1.defaultvalue),tconstsym(def2.defaultvalue)) then
  271. begin
  272. equal_paras:=false;
  273. exit;
  274. end;
  275. end;
  276. end;
  277. end;
  278. def1:=TParaItem(def1.next);
  279. def2:=TParaItem(def2.next);
  280. end;
  281. if (def1=nil) and (def2=nil) then
  282. equal_paras:=true
  283. else
  284. equal_paras:=false;
  285. end;
  286. function convertable_paras(paralist1,paralist2 : TLinkedList;acp : compare_type) : boolean;
  287. var
  288. def1,def2 : TParaItem;
  289. doconv : tconverttype;
  290. begin
  291. def1:=TParaItem(paralist1.first);
  292. def2:=TParaItem(paralist2.first);
  293. while (assigned(def1)) and (assigned(def2)) do
  294. begin
  295. case acp of
  296. cp_value_equal_const :
  297. begin
  298. if (isconvertable(def1.paratype.def,def2.paratype.def,doconv,callparan,false)=0) or
  299. ((def1.paratyp<>def2.paratyp) and
  300. ((def1.paratyp in [vs_out,vs_var]) or
  301. (def2.paratyp in [vs_out,vs_var])
  302. )
  303. ) then
  304. begin
  305. convertable_paras:=false;
  306. exit;
  307. end;
  308. end;
  309. cp_all :
  310. begin
  311. if (isconvertable(def1.paratype.def,def2.paratype.def,doconv,callparan,false)=0) or
  312. (def1.paratyp<>def2.paratyp) then
  313. begin
  314. convertable_paras:=false;
  315. exit;
  316. end;
  317. end;
  318. cp_none :
  319. begin
  320. if (isconvertable(def1.paratype.def,def2.paratype.def,doconv,callparan,false)=0) then
  321. begin
  322. convertable_paras:=false;
  323. exit;
  324. end;
  325. end;
  326. end;
  327. def1:=TParaItem(def1.next);
  328. def2:=TParaItem(def2.next);
  329. end;
  330. if (def1=nil) and (def2=nil) then
  331. convertable_paras:=true
  332. else
  333. convertable_paras:=false;
  334. end;
  335. { true if a function can be assigned to a procvar }
  336. function proc_to_procvar_equal(def1:tprocdef;def2:tprocvardef) : boolean;
  337. const
  338. po_comp = po_compatibility_options-[po_methodpointer,po_classmethod];
  339. var
  340. ismethod : boolean;
  341. begin
  342. proc_to_procvar_equal:=false;
  343. if not(assigned(def1)) or not(assigned(def2)) then
  344. exit;
  345. { check for method pointer }
  346. ismethod:=assigned(def1.owner) and
  347. (def1.owner.symtabletype=objectsymtable);
  348. { I think methods of objects are also not compatible }
  349. { with procedure variables! (FK)
  350. and
  351. assigned(def1.owner.defowner) and
  352. (tobjectdef(def1.owner.defowner)^.is_class); }
  353. if (ismethod and not (po_methodpointer in def2.procoptions)) or
  354. (not(ismethod) and (po_methodpointer in def2.procoptions)) then
  355. begin
  356. Message(type_e_no_method_and_procedure_not_compatible);
  357. exit;
  358. end;
  359. { check return value and para's and options, methodpointer is already checked
  360. parameters may also be convertable }
  361. if is_equal(def1.rettype.def,def2.rettype.def) and
  362. (equal_paras(def1.para,def2.para,cp_all) or
  363. convertable_paras(def1.para,def2.para,cp_all)) and
  364. ((po_comp * def1.procoptions)= (po_comp * def2.procoptions)) then
  365. proc_to_procvar_equal:=true
  366. else
  367. proc_to_procvar_equal:=false;
  368. end;
  369. { returns true, if def uses FPU }
  370. function is_fpu(def : tdef) : boolean;
  371. begin
  372. is_fpu:=(def.deftype=floatdef);
  373. end;
  374. { true if p is an ordinal }
  375. function is_ordinal(def : tdef) : boolean;
  376. var
  377. dt : tbasetype;
  378. begin
  379. case def.deftype of
  380. orddef :
  381. begin
  382. dt:=torddef(def).typ;
  383. is_ordinal:=dt in [uchar,uwidechar,
  384. u8bit,u16bit,u32bit,u64bit,
  385. s8bit,s16bit,s32bit,s64bit,
  386. bool8bit,bool16bit,bool32bit];
  387. end;
  388. enumdef :
  389. is_ordinal:=true;
  390. else
  391. is_ordinal:=false;
  392. end;
  393. end;
  394. { returns the min. value of the type }
  395. function get_min_value(def : tdef) : longint;
  396. begin
  397. case def.deftype of
  398. orddef:
  399. get_min_value:=torddef(def).low;
  400. enumdef:
  401. get_min_value:=tenumdef(def).min;
  402. else
  403. get_min_value:=0;
  404. end;
  405. end;
  406. { true if p is an integer }
  407. function is_integer(def : tdef) : boolean;
  408. begin
  409. is_integer:=(def.deftype=orddef) and
  410. (torddef(def).typ in [uauto,u8bit,u16bit,u32bit,u64bit,
  411. s8bit,s16bit,s32bit,s64bit]);
  412. end;
  413. { true if p is a boolean }
  414. function is_boolean(def : tdef) : boolean;
  415. begin
  416. is_boolean:=(def.deftype=orddef) and
  417. (torddef(def).typ in [bool8bit,bool16bit,bool32bit]);
  418. end;
  419. { true if p is a void }
  420. function is_void(def : tdef) : boolean;
  421. begin
  422. is_void:=(def.deftype=orddef) and
  423. (torddef(def).typ=uvoid);
  424. end;
  425. { true if p is a char }
  426. function is_char(def : tdef) : boolean;
  427. begin
  428. is_char:=(def.deftype=orddef) and
  429. (torddef(def).typ=uchar);
  430. end;
  431. { true if p is a wchar }
  432. function is_widechar(def : tdef) : boolean;
  433. begin
  434. is_widechar:=(def.deftype=orddef) and
  435. (torddef(def).typ=uwidechar);
  436. end;
  437. { true if p is signed (integer) }
  438. function is_signed(def : tdef) : boolean;
  439. var
  440. dt : tbasetype;
  441. begin
  442. case def.deftype of
  443. orddef :
  444. begin
  445. dt:=torddef(def).typ;
  446. is_signed:=(dt in [s8bit,s16bit,s32bit,s64bit]);
  447. end;
  448. enumdef :
  449. is_signed:=tenumdef(def).min < 0;
  450. arraydef :
  451. is_signed:=is_signed(tarraydef(def).rangetype.def);
  452. else
  453. is_signed:=false;
  454. end;
  455. end;
  456. { true, if p points to an open array def }
  457. function is_open_string(p : tdef) : boolean;
  458. begin
  459. is_open_string:=(p.deftype=stringdef) and
  460. (tstringdef(p).string_typ=st_shortstring) and
  461. (tstringdef(p).len=0);
  462. end;
  463. { true, if p points to a zero based array def }
  464. function is_zero_based_array(p : tdef) : boolean;
  465. begin
  466. is_zero_based_array:=(p.deftype=arraydef) and
  467. (tarraydef(p).lowrange=0) and
  468. not(is_special_array(p));
  469. end;
  470. { true if p points to a dynamic array def }
  471. function is_dynamic_array(p : tdef) : boolean;
  472. begin
  473. is_dynamic_array:=(p.deftype=arraydef) and
  474. tarraydef(p).IsDynamicArray;
  475. end;
  476. { true, if p points to an open array def }
  477. function is_open_array(p : tdef) : boolean;
  478. begin
  479. { check for s32bittype is needed, because for u32bit the high
  480. range is also -1 ! (PFV) }
  481. is_open_array:=(p.deftype=arraydef) and
  482. (tarraydef(p).rangetype.def=s32bittype.def) and
  483. (tarraydef(p).lowrange=0) and
  484. (tarraydef(p).highrange=-1) and
  485. not(tarraydef(p).IsConstructor) and
  486. not(tarraydef(p).IsVariant) and
  487. not(tarraydef(p).IsArrayOfConst) and
  488. not(tarraydef(p).IsDynamicArray);
  489. end;
  490. { true, if p points to an array of const def }
  491. function is_array_constructor(p : tdef) : boolean;
  492. begin
  493. is_array_constructor:=(p.deftype=arraydef) and
  494. (tarraydef(p).IsConstructor);
  495. end;
  496. { true, if p points to a variant array }
  497. function is_variant_array(p : tdef) : boolean;
  498. begin
  499. is_variant_array:=(p.deftype=arraydef) and
  500. (tarraydef(p).IsVariant);
  501. end;
  502. { true, if p points to an array of const }
  503. function is_array_of_const(p : tdef) : boolean;
  504. begin
  505. is_array_of_const:=(p.deftype=arraydef) and
  506. (tarraydef(p).IsArrayOfConst);
  507. end;
  508. { true, if p points to a special array }
  509. function is_special_array(p : tdef) : boolean;
  510. begin
  511. is_special_array:=(p.deftype=arraydef) and
  512. ((tarraydef(p).IsVariant) or
  513. (tarraydef(p).IsArrayOfConst) or
  514. (tarraydef(p).IsConstructor) or
  515. is_open_array(p)
  516. );
  517. end;
  518. { true if p is an ansi string def }
  519. function is_ansistring(p : tdef) : boolean;
  520. begin
  521. is_ansistring:=(p.deftype=stringdef) and
  522. (tstringdef(p).string_typ=st_ansistring);
  523. end;
  524. { true if p is an long string def }
  525. function is_longstring(p : tdef) : boolean;
  526. begin
  527. is_longstring:=(p.deftype=stringdef) and
  528. (tstringdef(p).string_typ=st_longstring);
  529. end;
  530. { true if p is an wide string def }
  531. function is_widestring(p : tdef) : boolean;
  532. begin
  533. is_widestring:=(p.deftype=stringdef) and
  534. (tstringdef(p).string_typ=st_widestring);
  535. end;
  536. { true if p is an short string def }
  537. function is_shortstring(p : tdef) : boolean;
  538. begin
  539. is_shortstring:=(p.deftype=stringdef) and
  540. (tstringdef(p).string_typ=st_shortstring);
  541. end;
  542. { true if p is a char array def }
  543. function is_chararray(p : tdef) : boolean;
  544. begin
  545. is_chararray:=(p.deftype=arraydef) and
  546. is_equal(tarraydef(p).elementtype.def,cchartype.def) and
  547. not(is_special_array(p));
  548. end;
  549. { true if p is a widechar array def }
  550. function is_widechararray(p : tdef) : boolean;
  551. begin
  552. is_widechararray:=(p.deftype=arraydef) and
  553. is_equal(tarraydef(p).elementtype.def,cwidechartype.def) and
  554. not(is_special_array(p));
  555. end;
  556. { true if p is a pchar def }
  557. function is_pchar(p : tdef) : boolean;
  558. begin
  559. is_pchar:=(p.deftype=pointerdef) and
  560. (is_equal(tpointerdef(p).pointertype.def,cchartype.def) or
  561. (is_zero_based_array(tpointerdef(p).pointertype.def) and
  562. is_chararray(tpointerdef(p).pointertype.def)));
  563. end;
  564. { true if p is a pchar def }
  565. function is_pwidechar(p : tdef) : boolean;
  566. begin
  567. is_pwidechar:=(p.deftype=pointerdef) and
  568. (is_equal(tpointerdef(p).pointertype.def,cwidechartype.def) or
  569. (is_zero_based_array(tpointerdef(p).pointertype.def) and
  570. is_widechararray(tpointerdef(p).pointertype.def)));
  571. end;
  572. { true if p is a voidpointer def }
  573. function is_voidpointer(p : tdef) : boolean;
  574. begin
  575. is_voidpointer:=(p.deftype=pointerdef) and
  576. (tpointerdef(p).pointertype.def.deftype=orddef) and
  577. (torddef(tpointerdef(p).pointertype.def).typ=uvoid);
  578. end;
  579. { true if p is a smallset def }
  580. function is_smallset(p : tdef) : boolean;
  581. begin
  582. is_smallset:=(p.deftype=setdef) and
  583. (tsetdef(p).settype=smallset);
  584. end;
  585. { true if the return value is in accumulator (EAX for i386), D0 for 68k }
  586. function ret_in_acc(def : tdef) : boolean;
  587. begin
  588. ret_in_acc:=(def.deftype in [orddef,pointerdef,enumdef,classrefdef]) or
  589. ((def.deftype=stringdef) and (tstringdef(def).string_typ in [st_ansistring,st_widestring])) or
  590. ((def.deftype=procvardef) and not(po_methodpointer in tprocvardef(def).procoptions)) or
  591. ((def.deftype=objectdef) and not is_object(def)) or
  592. ((def.deftype=setdef) and (tsetdef(def).settype=smallset));
  593. end;
  594. { true, if def is a 64 bit int type }
  595. function is_64bitint(def : tdef) : boolean;
  596. begin
  597. is_64bitint:=(def.deftype=orddef) and (torddef(def).typ in [u64bit,s64bit])
  598. end;
  599. { true if uses a parameter as return value }
  600. function ret_in_param(def : tdef) : boolean;
  601. begin
  602. ret_in_param:=(def.deftype in [arraydef,recorddef]) or
  603. ((def.deftype=stringdef) and (tstringdef(def).string_typ in [st_shortstring,st_longstring])) or
  604. ((def.deftype=procvardef) and (po_methodpointer in tprocvardef(def).procoptions)) or
  605. ((def.deftype=objectdef) and is_object(def)) or
  606. ((def.deftype=setdef) and (tsetdef(def).settype<>smallset));
  607. end;
  608. function push_high_param(def : tdef) : boolean;
  609. begin
  610. push_high_param:=is_open_array(def) or
  611. is_open_string(def) or
  612. is_array_of_const(def);
  613. end;
  614. { true if a parameter is too large to copy and only the address is pushed }
  615. function push_addr_param(def : tdef) : boolean;
  616. begin
  617. push_addr_param:=false;
  618. if never_copy_const_param then
  619. push_addr_param:=true
  620. else
  621. begin
  622. case def.deftype of
  623. variantdef,
  624. formaldef :
  625. push_addr_param:=true;
  626. recorddef :
  627. push_addr_param:=(def.size>target_info.size_of_pointer);
  628. arraydef :
  629. push_addr_param:=((tarraydef(def).highrange>=tarraydef(def).lowrange) and (def.size>target_info.size_of_pointer)) or
  630. is_open_array(def) or
  631. is_array_of_const(def) or
  632. is_array_constructor(def);
  633. objectdef :
  634. push_addr_param:=is_object(def);
  635. stringdef :
  636. push_addr_param:=tstringdef(def).string_typ in [st_shortstring,st_longstring];
  637. procvardef :
  638. push_addr_param:=(po_methodpointer in tprocvardef(def).procoptions);
  639. setdef :
  640. push_addr_param:=(tsetdef(def).settype<>smallset);
  641. end;
  642. end;
  643. end;
  644. { if l isn't in the range of def a range check error (if not explicit) is generated and
  645. the value is placed within the range }
  646. procedure testrange(def : tdef;var l : tconstexprint;explicit:boolean);
  647. var
  648. lv,hv: longint;
  649. error: boolean;
  650. begin
  651. error := false;
  652. { for 64 bit types we need only to check if it is less than }
  653. { zero, if def is a qword node }
  654. if is_64bitint(def) then
  655. begin
  656. if (l<0) and (torddef(def).typ=u64bit) then
  657. begin
  658. { don't zero the result, because it may come from hex notation
  659. like $ffffffffffffffff! (JM)
  660. l:=0; }
  661. if not explicit then
  662. begin
  663. if (cs_check_range in aktlocalswitches) then
  664. Message(parser_e_range_check_error)
  665. else
  666. Message(parser_w_range_check_error);
  667. end;
  668. error := true;
  669. end;
  670. end
  671. else
  672. begin
  673. getrange(def,lv,hv);
  674. if (def.deftype=orddef) and
  675. (torddef(def).typ=u32bit) then
  676. begin
  677. if (l < cardinal(lv)) or
  678. (l > cardinal(hv)) then
  679. begin
  680. if not explicit then
  681. begin
  682. if (cs_check_range in aktlocalswitches) then
  683. Message(parser_e_range_check_error)
  684. else
  685. Message(parser_w_range_check_error);
  686. end;
  687. error := true;
  688. end;
  689. end
  690. else if (l<lv) or (l>hv) then
  691. begin
  692. if not explicit then
  693. begin
  694. if ((def.deftype=enumdef) and
  695. { delphi allows range check errors in
  696. enumeration type casts FK }
  697. not(m_delphi in aktmodeswitches)) or
  698. (cs_check_range in aktlocalswitches) then
  699. Message(parser_e_range_check_error)
  700. else
  701. Message(parser_w_range_check_error);
  702. end;
  703. error := true;
  704. end;
  705. end;
  706. if error then
  707. begin
  708. { Fix the value to fit in the allocated space for this type of variable }
  709. case def.size of
  710. 1: l := l and $ff;
  711. 2: l := l and $ffff;
  712. { work around sign extension bug (to be fixed) (JM) }
  713. 4: l := l and (int64($fffffff) shl 4 + $f);
  714. end;
  715. { do sign extension if necessary (JM) }
  716. if is_signed(def) then
  717. begin
  718. case def.size of
  719. 1: l := shortint(l);
  720. 2: l := smallint(l);
  721. 4: l := longint(l);
  722. end;
  723. end;
  724. end;
  725. end;
  726. { return the range from def in l and h }
  727. procedure getrange(def : tdef;var l : longint;var h : longint);
  728. begin
  729. case def.deftype of
  730. orddef :
  731. begin
  732. l:=torddef(def).low;
  733. h:=torddef(def).high;
  734. end;
  735. enumdef :
  736. begin
  737. l:=tenumdef(def).min;
  738. h:=tenumdef(def).max;
  739. end;
  740. arraydef :
  741. begin
  742. l:=tarraydef(def).lowrange;
  743. h:=tarraydef(def).highrange;
  744. end;
  745. else
  746. internalerror(987);
  747. end;
  748. end;
  749. function mmx_type(p : tdef) : tmmxtype;
  750. begin
  751. mmx_type:=mmxno;
  752. if is_mmx_able_array(p) then
  753. begin
  754. if tarraydef(p).elementtype.def.deftype=floatdef then
  755. case tfloatdef(tarraydef(p).elementtype.def).typ of
  756. s32real:
  757. mmx_type:=mmxsingle;
  758. end
  759. else
  760. case torddef(tarraydef(p).elementtype.def).typ of
  761. u8bit:
  762. mmx_type:=mmxu8bit;
  763. s8bit:
  764. mmx_type:=mmxs8bit;
  765. u16bit:
  766. mmx_type:=mmxu16bit;
  767. s16bit:
  768. mmx_type:=mmxs16bit;
  769. u32bit:
  770. mmx_type:=mmxu32bit;
  771. s32bit:
  772. mmx_type:=mmxs32bit;
  773. end;
  774. end;
  775. end;
  776. function is_mmx_able_array(p : tdef) : boolean;
  777. begin
  778. {$ifdef SUPPORT_MMX}
  779. if (cs_mmx_saturation in aktlocalswitches) then
  780. begin
  781. is_mmx_able_array:=(p.deftype=arraydef) and
  782. not(is_special_array(p)) and
  783. (
  784. (
  785. (tarraydef(p).elementtype.def.deftype=orddef) and
  786. (
  787. (
  788. (tarraydef(p).lowrange=0) and
  789. (tarraydef(p).highrange=1) and
  790. (torddef(tarraydef(p).elementtype.def).typ in [u32bit,s32bit])
  791. )
  792. or
  793. (
  794. (tarraydef(p).lowrange=0) and
  795. (tarraydef(p).highrange=3) and
  796. (torddef(tarraydef(p).elementtype.def).typ in [u16bit,s16bit])
  797. )
  798. )
  799. )
  800. or
  801. (
  802. (
  803. (tarraydef(p).elementtype.def.deftype=floatdef) and
  804. (
  805. (tarraydef(p).lowrange=0) and
  806. (tarraydef(p).highrange=1) and
  807. (tfloatdef(tarraydef(p).elementtype.def).typ=s32real)
  808. )
  809. )
  810. )
  811. );
  812. end
  813. else
  814. begin
  815. is_mmx_able_array:=(p.deftype=arraydef) and
  816. (
  817. (
  818. (tarraydef(p).elementtype.def.deftype=orddef) and
  819. (
  820. (
  821. (tarraydef(p).lowrange=0) and
  822. (tarraydef(p).highrange=1) and
  823. (torddef(tarraydef(p).elementtype.def).typ in [u32bit,s32bit])
  824. )
  825. or
  826. (
  827. (tarraydef(p).lowrange=0) and
  828. (tarraydef(p).highrange=3) and
  829. (torddef(tarraydef(p).elementtype.def).typ in [u16bit,s16bit])
  830. )
  831. or
  832. (
  833. (tarraydef(p).lowrange=0) and
  834. (tarraydef(p).highrange=7) and
  835. (torddef(tarraydef(p).elementtype.def).typ in [u8bit,s8bit])
  836. )
  837. )
  838. )
  839. or
  840. (
  841. (tarraydef(p).elementtype.def.deftype=floatdef) and
  842. (
  843. (tarraydef(p).lowrange=0) and
  844. (tarraydef(p).highrange=1) and
  845. (tfloatdef(tarraydef(p).elementtype.def).typ=s32real)
  846. )
  847. )
  848. );
  849. end;
  850. {$else SUPPORT_MMX}
  851. is_mmx_able_array:=false;
  852. {$endif SUPPORT_MMX}
  853. end;
  854. function is_equal(def1,def2 : tdef) : boolean;
  855. var
  856. b : boolean;
  857. hd : tdef;
  858. begin
  859. { both types must exists }
  860. if not (assigned(def1) and assigned(def2)) then
  861. begin
  862. is_equal:=false;
  863. exit;
  864. end;
  865. { be sure, that if there is a stringdef, that this is def1 }
  866. if def2.deftype=stringdef then
  867. begin
  868. hd:=def1;
  869. def1:=def2;
  870. def2:=hd;
  871. end;
  872. b:=false;
  873. { both point to the same definition ? }
  874. if def1=def2 then
  875. b:=true
  876. else
  877. { pointer with an equal definition are equal }
  878. if (def1.deftype=pointerdef) and (def2.deftype=pointerdef) then
  879. begin
  880. { check if both are farpointer }
  881. if (tpointerdef(def1).is_far=tpointerdef(def2).is_far) then
  882. begin
  883. { here a problem detected in tabsolutesym }
  884. { the types can be forward type !! }
  885. if assigned(def1.typesym) and (tpointerdef(def1).pointertype.def.deftype=forwarddef) then
  886. b:=(def1.typesym=def2.typesym)
  887. else
  888. b:=tpointerdef(def1).pointertype.def=tpointerdef(def2).pointertype.def;
  889. end
  890. else
  891. b:=false;
  892. end
  893. else
  894. { ordinals are equal only when the ordinal type is equal }
  895. if (def1.deftype=orddef) and (def2.deftype=orddef) then
  896. begin
  897. case torddef(def1).typ of
  898. u8bit,u16bit,u32bit,
  899. s8bit,s16bit,s32bit:
  900. b:=((torddef(def1).typ=torddef(def2).typ) and
  901. (torddef(def1).low=torddef(def2).low) and
  902. (torddef(def1).high=torddef(def2).high));
  903. uvoid,uchar,uwidechar,
  904. bool8bit,bool16bit,bool32bit:
  905. b:=(torddef(def1).typ=torddef(def2).typ);
  906. end;
  907. end
  908. else
  909. if (def1.deftype=floatdef) and (def2.deftype=floatdef) then
  910. b:=tfloatdef(def1).typ=tfloatdef(def2).typ
  911. else
  912. { strings with the same length are equal }
  913. if (def1.deftype=stringdef) and (def2.deftype=stringdef) and
  914. (tstringdef(def1).string_typ=tstringdef(def2).string_typ) then
  915. begin
  916. b:=not(is_shortstring(def1)) or
  917. (tstringdef(def1).len=tstringdef(def2).len);
  918. end
  919. else
  920. if (def1.deftype=formaldef) and (def2.deftype=formaldef) then
  921. b:=true
  922. { file types with the same file element type are equal }
  923. { this is a problem for assign !! }
  924. { changed to allow if one is untyped }
  925. { all typed files are equal to the special }
  926. { typed file that has voiddef as elemnt type }
  927. { but must NOT match for text file !!! }
  928. else
  929. if (def1.deftype=filedef) and (def2.deftype=filedef) then
  930. b:=(tfiledef(def1).filetyp=tfiledef(def2).filetyp) and
  931. ((
  932. ((tfiledef(def1).typedfiletype.def=nil) and
  933. (tfiledef(def2).typedfiletype.def=nil)) or
  934. (
  935. (tfiledef(def1).typedfiletype.def<>nil) and
  936. (tfiledef(def2).typedfiletype.def<>nil) and
  937. is_equal(tfiledef(def1).typedfiletype.def,tfiledef(def2).typedfiletype.def)
  938. ) or
  939. ( (tfiledef(def1).typedfiletype.def=tdef(voidtype.def)) or
  940. (tfiledef(def2).typedfiletype.def=tdef(voidtype.def))
  941. )))
  942. { sets with the same element base type are equal }
  943. else
  944. if (def1.deftype=setdef) and (def2.deftype=setdef) then
  945. begin
  946. if assigned(tsetdef(def1).elementtype.def) and
  947. assigned(tsetdef(def2).elementtype.def) then
  948. b:=is_subequal(tsetdef(def1).elementtype.def,tsetdef(def2).elementtype.def)
  949. else
  950. { empty set is compatible with everything }
  951. b:=true;
  952. end
  953. else
  954. if (def1.deftype=procvardef) and (def2.deftype=procvardef) then
  955. begin
  956. { poassembler isn't important for compatibility }
  957. { if a method is assigned to a methodpointer }
  958. { is checked before }
  959. b:=(tprocvardef(def1).proctypeoption=tprocvardef(def2).proctypeoption) and
  960. (tprocvardef(def1).proccalloptions=tprocvardef(def2).proccalloptions) and
  961. ((tprocvardef(def1).procoptions * po_compatibility_options)=
  962. (tprocvardef(def2).procoptions * po_compatibility_options)) and
  963. is_equal(tprocvardef(def1).rettype.def,tprocvardef(def2).rettype.def) and
  964. equal_paras(tprocvardef(def1).para,tprocvardef(def2).para,cp_all);
  965. end
  966. else
  967. if (def1.deftype=arraydef) and (def2.deftype=arraydef) then
  968. begin
  969. if is_dynamic_array(def1) and is_dynamic_array(def2) then
  970. b:=is_equal(tarraydef(def1).elementtype.def,tarraydef(def2).elementtype.def)
  971. else
  972. if is_array_of_const(def1) or is_array_of_const(def2) then
  973. begin
  974. b:=(is_array_of_const(def1) and is_array_of_const(def2)) or
  975. (is_array_of_const(def1) and is_array_constructor(def2)) or
  976. (is_array_of_const(def2) and is_array_constructor(def1));
  977. end
  978. else
  979. if is_open_array(def1) or is_open_array(def2) then
  980. begin
  981. b:=is_equal(tarraydef(def1).elementtype.def,tarraydef(def2).elementtype.def);
  982. end
  983. else
  984. begin
  985. b:=not(m_tp in aktmodeswitches) and
  986. not(m_delphi in aktmodeswitches) and
  987. (tarraydef(def1).lowrange=tarraydef(def2).lowrange) and
  988. (tarraydef(def1).highrange=tarraydef(def2).highrange) and
  989. is_equal(tarraydef(def1).elementtype.def,tarraydef(def2).elementtype.def) and
  990. is_equal(tarraydef(def1).rangetype.def,tarraydef(def2).rangetype.def);
  991. end;
  992. end
  993. else
  994. if (def1.deftype=classrefdef) and (def2.deftype=classrefdef) then
  995. begin
  996. { similar to pointerdef: }
  997. if assigned(def1.typesym) and (tclassrefdef(def1).pointertype.def.deftype=forwarddef) then
  998. b:=(def1.typesym=def2.typesym)
  999. else
  1000. b:=is_equal(tclassrefdef(def1).pointertype.def,tclassrefdef(def2).pointertype.def);
  1001. end;
  1002. is_equal:=b;
  1003. end;
  1004. function is_subequal(def1, def2: tdef): boolean;
  1005. var
  1006. basedef1,basedef2 : tenumdef;
  1007. Begin
  1008. is_subequal := false;
  1009. if assigned(def1) and assigned(def2) then
  1010. Begin
  1011. if (def1.deftype = orddef) and (def2.deftype = orddef) then
  1012. Begin
  1013. { see p.47 of Turbo Pascal 7.01 manual for the separation of types }
  1014. { range checking for case statements is done with testrange }
  1015. case torddef(def1).typ of
  1016. u8bit,u16bit,u32bit,
  1017. s8bit,s16bit,s32bit,s64bit,u64bit :
  1018. is_subequal:=(torddef(def2).typ in [s64bit,u64bit,s32bit,u32bit,u8bit,s8bit,s16bit,u16bit]);
  1019. bool8bit,bool16bit,bool32bit :
  1020. is_subequal:=(torddef(def2).typ in [bool8bit,bool16bit,bool32bit]);
  1021. uchar :
  1022. is_subequal:=(torddef(def2).typ=uchar);
  1023. end;
  1024. end
  1025. else
  1026. Begin
  1027. { I assume that both enumerations are equal when the first }
  1028. { pointers are equal. }
  1029. { I changed this to assume that the enums are equal }
  1030. { if the basedefs are equal (FK) }
  1031. if (def1.deftype=enumdef) and (def2.deftype=enumdef) then
  1032. Begin
  1033. { get both basedefs }
  1034. basedef1:=tenumdef(def1);
  1035. while assigned(basedef1.basedef) do
  1036. basedef1:=basedef1.basedef;
  1037. basedef2:=tenumdef(def2);
  1038. while assigned(basedef2.basedef) do
  1039. basedef2:=basedef2.basedef;
  1040. is_subequal:=basedef1=basedef2;
  1041. {
  1042. if tenumdef(def1).firstenum = tenumdef(def2).firstenum then
  1043. is_subequal := TRUE;
  1044. }
  1045. end;
  1046. end;
  1047. end; { endif assigned ... }
  1048. end;
  1049. function assignment_overloaded(from_def,to_def : tdef) : tprocdef;
  1050. var
  1051. passproc : tprocdef;
  1052. convtyp : tconverttype;
  1053. begin
  1054. assignment_overloaded:=nil;
  1055. if assigned(overloaded_operators[_ASSIGNMENT]) then
  1056. passproc:=overloaded_operators[_ASSIGNMENT].definition
  1057. else
  1058. exit;
  1059. { look for an exact match first }
  1060. while passproc<>nil do
  1061. begin
  1062. if is_equal(passproc.rettype.def,to_def) and
  1063. (TParaItem(passproc.Para.first).paratype.def=from_def) then
  1064. begin
  1065. assignment_overloaded:=passproc;
  1066. exit;
  1067. end;
  1068. passproc:=passproc.nextoverloaded;
  1069. end;
  1070. passproc:=overloaded_operators[_ASSIGNMENT].definition;
  1071. { .... then look for an equal match }
  1072. while passproc<>nil do
  1073. begin
  1074. if is_equal(passproc.rettype.def,to_def) and
  1075. is_equal(TParaItem(passproc.Para.first).paratype.def,from_def) then
  1076. begin
  1077. assignment_overloaded:=passproc;
  1078. exit;
  1079. end;
  1080. passproc:=passproc.nextoverloaded;
  1081. end;
  1082. passproc:=overloaded_operators[_ASSIGNMENT].definition;
  1083. { .... then for convert level 1 }
  1084. while passproc<>nil do
  1085. begin
  1086. if is_equal(passproc.rettype.def,to_def) and
  1087. (isconvertable(from_def,TParaItem(passproc.Para.first).paratype.def,convtyp,ordconstn,false)=1) then
  1088. begin
  1089. assignment_overloaded:=passproc;
  1090. exit;
  1091. end;
  1092. passproc:=passproc.nextoverloaded;
  1093. end;
  1094. end;
  1095. { Returns:
  1096. 0 - Not convertable
  1097. 1 - Convertable
  1098. 2 - Convertable, but not first choice }
  1099. function isconvertable(def_from,def_to : tdef;
  1100. var doconv : tconverttype;
  1101. fromtreetype : tnodetype;
  1102. explicit : boolean) : byte;
  1103. { Tbasetype: uauto,uvoid,uchar,
  1104. u8bit,u16bit,u32bit,
  1105. s8bit,s16bit,s32,
  1106. bool8bit,bool16bit,bool32bit,
  1107. u64bit,s64bitint,uwidechar }
  1108. type
  1109. tbasedef=(bvoid,bchar,bint,bbool);
  1110. const
  1111. basedeftbl:array[tbasetype] of tbasedef =
  1112. (bvoid,bvoid,bchar,
  1113. bint,bint,bint,
  1114. bint,bint,bint,
  1115. bbool,bbool,bbool,bint,bint,bchar);
  1116. basedefconverts : array[tbasedef,tbasedef] of tconverttype =
  1117. ((tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible),
  1118. (tc_not_possible,tc_char_2_char,tc_not_possible,tc_not_possible),
  1119. (tc_not_possible,tc_not_possible,tc_int_2_int,tc_int_2_bool),
  1120. (tc_not_possible,tc_not_possible,tc_bool_2_int,tc_bool_2_bool));
  1121. var
  1122. b : byte;
  1123. hd1,hd2 : tdef;
  1124. hct : tconverttype;
  1125. begin
  1126. { safety check }
  1127. if not(assigned(def_from) and assigned(def_to)) then
  1128. begin
  1129. isconvertable:=0;
  1130. exit;
  1131. end;
  1132. { tp7 procvar def support, in tp7 a procvar is always called, if the
  1133. procvar is passed explicit a addrn would be there }
  1134. if (m_tp_procvar in aktmodeswitches) and
  1135. (def_from.deftype=procvardef) and
  1136. (fromtreetype=loadn) then
  1137. begin
  1138. def_from:=tprocvardef(def_from).rettype.def;
  1139. end;
  1140. { we walk the wanted (def_to) types and check then the def_from
  1141. types if there is a conversion possible }
  1142. b:=0;
  1143. case def_to.deftype of
  1144. orddef :
  1145. begin
  1146. case def_from.deftype of
  1147. orddef :
  1148. begin
  1149. doconv:=basedefconverts[basedeftbl[torddef(def_from).typ],basedeftbl[torddef(def_to).typ]];
  1150. b:=1;
  1151. if (doconv=tc_not_possible) or
  1152. ((doconv=tc_int_2_bool) and
  1153. (not explicit) and
  1154. (not is_boolean(def_from))) or
  1155. ((doconv=tc_bool_2_int) and
  1156. (not explicit) and
  1157. (not is_boolean(def_to))) then
  1158. b:=0;
  1159. end;
  1160. enumdef :
  1161. begin
  1162. { needed for char(enum) }
  1163. if explicit then
  1164. begin
  1165. doconv:=tc_int_2_int;
  1166. b:=1;
  1167. end;
  1168. end;
  1169. end;
  1170. end;
  1171. stringdef :
  1172. begin
  1173. case def_from.deftype of
  1174. stringdef :
  1175. begin
  1176. doconv:=tc_string_2_string;
  1177. b:=1;
  1178. end;
  1179. orddef :
  1180. begin
  1181. { char to string}
  1182. if is_char(def_from) or
  1183. is_widechar(def_from) then
  1184. begin
  1185. doconv:=tc_char_2_string;
  1186. b:=1;
  1187. end;
  1188. end;
  1189. arraydef :
  1190. begin
  1191. { array of char to string, the length check is done by the firstpass of this node }
  1192. if is_chararray(def_from) then
  1193. begin
  1194. doconv:=tc_chararray_2_string;
  1195. if (is_shortstring(def_to) and
  1196. (def_from.size <= 255)) or
  1197. (is_ansistring(def_to) and
  1198. (def_from.size > 255)) then
  1199. b:=1
  1200. else
  1201. b:=2;
  1202. end;
  1203. end;
  1204. pointerdef :
  1205. begin
  1206. { pchar can be assigned to short/ansistrings,
  1207. but not in tp7 compatible mode }
  1208. if is_pchar(def_from) and not(m_tp7 in aktmodeswitches) then
  1209. begin
  1210. doconv:=tc_pchar_2_string;
  1211. { trefer ansistrings because pchars can overflow shortstrings, }
  1212. { but only if ansistrings are the default (JM) }
  1213. if (is_shortstring(def_to) and
  1214. not(cs_ansistrings in aktlocalswitches)) or
  1215. (is_ansistring(def_to) and
  1216. (cs_ansistrings in aktlocalswitches)) then
  1217. b:=1
  1218. else
  1219. b:=2;
  1220. end;
  1221. end;
  1222. end;
  1223. end;
  1224. floatdef :
  1225. begin
  1226. case def_from.deftype of
  1227. orddef :
  1228. begin { ordinal to real }
  1229. if is_integer(def_from) then
  1230. begin
  1231. doconv:=tc_int_2_real;
  1232. b:=1;
  1233. end;
  1234. end;
  1235. floatdef :
  1236. begin { 2 float types ? }
  1237. if tfloatdef(def_from).typ=tfloatdef(def_to).typ then
  1238. doconv:=tc_equal
  1239. else
  1240. doconv:=tc_real_2_real;
  1241. b:=1;
  1242. end;
  1243. end;
  1244. end;
  1245. enumdef :
  1246. begin
  1247. if (def_from.deftype=enumdef) then
  1248. begin
  1249. hd1:=def_from;
  1250. while assigned(tenumdef(hd1).basedef) do
  1251. hd1:=tenumdef(hd1).basedef;
  1252. hd2:=def_to;
  1253. while assigned(tenumdef(hd2).basedef) do
  1254. hd2:=tenumdef(hd2).basedef;
  1255. if (hd1=hd2) then
  1256. begin
  1257. b:=1;
  1258. { because of packenum they can have different sizes! (JM) }
  1259. doconv:=tc_int_2_int;
  1260. end;
  1261. end;
  1262. end;
  1263. arraydef :
  1264. begin
  1265. { open array is also compatible with a single element of its base type }
  1266. if is_open_array(def_to) and
  1267. is_equal(tarraydef(def_to).elementtype.def,def_from) then
  1268. begin
  1269. doconv:=tc_equal;
  1270. b:=1;
  1271. end
  1272. else
  1273. begin
  1274. case def_from.deftype of
  1275. arraydef :
  1276. begin
  1277. { array constructor -> open array }
  1278. if is_open_array(def_to) and
  1279. is_array_constructor(def_from) then
  1280. begin
  1281. if is_void(tarraydef(def_from).elementtype.def) or
  1282. is_equal(tarraydef(def_to).elementtype.def,tarraydef(def_from).elementtype.def) then
  1283. begin
  1284. doconv:=tc_equal;
  1285. b:=1;
  1286. end
  1287. else
  1288. if isconvertable(tarraydef(def_from).elementtype.def,
  1289. tarraydef(def_to).elementtype.def,hct,arrayconstructorn,false)<>0 then
  1290. begin
  1291. doconv:=hct;
  1292. b:=2;
  1293. end;
  1294. end
  1295. else
  1296. { array of tvarrec -> array of const }
  1297. if is_array_of_const(def_to) and
  1298. is_equal(tarraydef(def_to).elementtype.def,tarraydef(def_from).elementtype.def) then
  1299. begin
  1300. doconv:=tc_equal;
  1301. b:=1;
  1302. end;
  1303. end;
  1304. pointerdef :
  1305. begin
  1306. if is_zero_based_array(def_to) and
  1307. is_equal(tpointerdef(def_from).pointertype.def,tarraydef(def_to).elementtype.def) then
  1308. begin
  1309. doconv:=tc_pointer_2_array;
  1310. b:=1;
  1311. end;
  1312. end;
  1313. stringdef :
  1314. begin
  1315. { string to char array }
  1316. if (not is_special_array(def_to)) and
  1317. is_char(tarraydef(def_to).elementtype.def) then
  1318. begin
  1319. doconv:=tc_string_2_chararray;
  1320. b:=1;
  1321. end;
  1322. end;
  1323. recorddef :
  1324. begin
  1325. { tvarrec -> array of constconst }
  1326. if is_array_of_const(def_to) and
  1327. is_equal(def_from,tarraydef(def_to).elementtype.def) then
  1328. begin
  1329. doconv:=tc_equal;
  1330. b:=1;
  1331. end;
  1332. end;
  1333. end;
  1334. end;
  1335. end;
  1336. pointerdef :
  1337. begin
  1338. case def_from.deftype of
  1339. stringdef :
  1340. begin
  1341. { string constant (which can be part of array constructor)
  1342. to zero terminated string constant }
  1343. if (fromtreetype in [arrayconstructorn,stringconstn]) and
  1344. is_pchar(def_to) or is_pwidechar(def_to) then
  1345. begin
  1346. doconv:=tc_cstring_2_pchar;
  1347. b:=1;
  1348. end;
  1349. end;
  1350. orddef :
  1351. begin
  1352. { char constant to zero terminated string constant }
  1353. if (fromtreetype=ordconstn) then
  1354. begin
  1355. if is_equal(def_from,cchartype.def) and
  1356. is_pchar(def_to) then
  1357. begin
  1358. doconv:=tc_cchar_2_pchar;
  1359. b:=1;
  1360. end
  1361. else
  1362. if is_integer(def_from) then
  1363. begin
  1364. doconv:=tc_cord_2_pointer;
  1365. b:=1;
  1366. end;
  1367. end;
  1368. end;
  1369. arraydef :
  1370. begin
  1371. { chararray to pointer }
  1372. if is_zero_based_array(def_from) and
  1373. is_equal(tarraydef(def_from).elementtype.def,tpointerdef(def_to).pointertype.def) then
  1374. begin
  1375. doconv:=tc_array_2_pointer;
  1376. b:=1;
  1377. end;
  1378. end;
  1379. pointerdef :
  1380. begin
  1381. { child class pointer can be assigned to anchestor pointers }
  1382. if (
  1383. (tpointerdef(def_from).pointertype.def.deftype=objectdef) and
  1384. (tpointerdef(def_to).pointertype.def.deftype=objectdef) and
  1385. tobjectdef(tpointerdef(def_from).pointertype.def).is_related(
  1386. tobjectdef(tpointerdef(def_to).pointertype.def))
  1387. ) or
  1388. { all pointers can be assigned to void-pointer }
  1389. is_equal(tpointerdef(def_to).pointertype.def,voidtype.def) or
  1390. { in my opnion, is this not clean pascal }
  1391. { well, but it's handy to use, it isn't ? (FK) }
  1392. is_equal(tpointerdef(def_from).pointertype.def,voidtype.def) then
  1393. begin
  1394. { but don't allow conversion between farpointer-pointer }
  1395. if (tpointerdef(def_to).is_far=tpointerdef(def_from).is_far) then
  1396. begin
  1397. doconv:=tc_equal;
  1398. b:=1;
  1399. end;
  1400. end;
  1401. end;
  1402. procvardef :
  1403. begin
  1404. { procedure variable can be assigned to an void pointer }
  1405. { Not anymore. Use the @ operator now.}
  1406. if not(m_tp_procvar in aktmodeswitches) and
  1407. (tpointerdef(def_to).pointertype.def.deftype=orddef) and
  1408. (torddef(tpointerdef(def_to).pointertype.def).typ=uvoid) then
  1409. begin
  1410. doconv:=tc_equal;
  1411. b:=1;
  1412. end;
  1413. end;
  1414. classrefdef,
  1415. objectdef :
  1416. begin
  1417. { class types and class reference type
  1418. can be assigned to void pointers }
  1419. if (
  1420. is_class_or_interface(def_from) or
  1421. (def_from.deftype=classrefdef)
  1422. ) and
  1423. (tpointerdef(def_to).pointertype.def.deftype=orddef) and
  1424. (torddef(tpointerdef(def_to).pointertype.def).typ=uvoid) then
  1425. begin
  1426. doconv:=tc_equal;
  1427. b:=1;
  1428. end;
  1429. end;
  1430. end;
  1431. end;
  1432. setdef :
  1433. begin
  1434. { automatic arrayconstructor -> set conversion }
  1435. if is_array_constructor(def_from) then
  1436. begin
  1437. doconv:=tc_arrayconstructor_2_set;
  1438. b:=1;
  1439. end;
  1440. end;
  1441. procvardef :
  1442. begin
  1443. { proc -> procvar }
  1444. if (def_from.deftype=procdef) and
  1445. (m_tp_procvar in aktmodeswitches) then
  1446. begin
  1447. doconv:=tc_proc_2_procvar;
  1448. if proc_to_procvar_equal(tprocdef(def_from),tprocvardef(def_to)) then
  1449. b:=1;
  1450. end
  1451. else
  1452. { for example delphi allows the assignement from pointers }
  1453. { to procedure variables }
  1454. if (m_pointer_2_procedure in aktmodeswitches) and
  1455. (def_from.deftype=pointerdef) and
  1456. (tpointerdef(def_from).pointertype.def.deftype=orddef) and
  1457. (torddef(tpointerdef(def_from).pointertype.def).typ=uvoid) then
  1458. begin
  1459. doconv:=tc_equal;
  1460. b:=1;
  1461. end
  1462. else
  1463. { nil is compatible with procvars }
  1464. if (fromtreetype=niln) then
  1465. begin
  1466. doconv:=tc_equal;
  1467. b:=1;
  1468. end;
  1469. end;
  1470. objectdef :
  1471. begin
  1472. { object pascal objects }
  1473. if (def_from.deftype=objectdef) and
  1474. tobjectdef(def_from).is_related(tobjectdef(def_to)) then
  1475. begin
  1476. doconv:=tc_equal;
  1477. b:=1;
  1478. end
  1479. else
  1480. { Class/interface specific }
  1481. if is_class_or_interface(def_to) then
  1482. begin
  1483. { void pointer also for delphi mode }
  1484. if (m_delphi in aktmodeswitches) and
  1485. is_voidpointer(def_from) then
  1486. begin
  1487. doconv:=tc_equal;
  1488. b:=1;
  1489. end
  1490. else
  1491. { nil is compatible with class instances and interfaces }
  1492. if (fromtreetype=niln) then
  1493. begin
  1494. doconv:=tc_equal;
  1495. b:=1;
  1496. end
  1497. { classes can be assigned to interfaces }
  1498. else if is_interface(def_to) and
  1499. is_class(def_from) and
  1500. assigned(tobjectdef(def_from).implementedinterfaces) and
  1501. (tobjectdef(def_from).implementedinterfaces.searchintf(def_to)<>-1) then
  1502. begin
  1503. doconv:=tc_class_2_intf;
  1504. b:=1;
  1505. end
  1506. { Interface 2 GUID handling }
  1507. else if (def_to=tdef(rec_tguid)) and
  1508. (fromtreetype=typen) and
  1509. is_interface(def_from) and
  1510. tobjectdef(def_from).isiidguidvalid then
  1511. begin
  1512. b:=1;
  1513. doconv:=tc_equal;
  1514. end;
  1515. end;
  1516. end;
  1517. classrefdef :
  1518. begin
  1519. { class reference types }
  1520. if (def_from.deftype=classrefdef) then
  1521. begin
  1522. doconv:=tc_equal;
  1523. if tobjectdef(tclassrefdef(def_from).pointertype.def).is_related(
  1524. tobjectdef(tclassrefdef(def_to).pointertype.def)) then
  1525. b:=1;
  1526. end
  1527. else
  1528. { nil is compatible with class references }
  1529. if (fromtreetype=niln) then
  1530. begin
  1531. doconv:=tc_equal;
  1532. b:=1;
  1533. end;
  1534. end;
  1535. filedef :
  1536. begin
  1537. { typed files are all equal to the abstract file type
  1538. name TYPEDFILE in system.pp in is_equal in types.pas
  1539. the problem is that it sholud be also compatible to FILE
  1540. but this would leed to a problem for ASSIGN RESET and REWRITE
  1541. when trying to find the good overloaded function !!
  1542. so all file function are doubled in system.pp
  1543. this is not very beautiful !!}
  1544. if (def_from.deftype=filedef) and
  1545. (
  1546. (
  1547. (tfiledef(def_from).filetyp = ft_typed) and
  1548. (tfiledef(def_to).filetyp = ft_typed) and
  1549. (
  1550. (tfiledef(def_from).typedfiletype.def = tdef(voidtype.def)) or
  1551. (tfiledef(def_to).typedfiletype.def = tdef(voidtype.def))
  1552. )
  1553. ) or
  1554. (
  1555. (
  1556. (tfiledef(def_from).filetyp = ft_untyped) and
  1557. (tfiledef(def_to).filetyp = ft_typed)
  1558. ) or
  1559. (
  1560. (tfiledef(def_from).filetyp = ft_typed) and
  1561. (tfiledef(def_to).filetyp = ft_untyped)
  1562. )
  1563. )
  1564. ) then
  1565. begin
  1566. doconv:=tc_equal;
  1567. b:=1;
  1568. end
  1569. end;
  1570. else
  1571. begin
  1572. { assignment overwritten ?? }
  1573. if assignment_overloaded(def_from,def_to)<>nil then
  1574. b:=2;
  1575. end;
  1576. end;
  1577. isconvertable:=b;
  1578. end;
  1579. function CheckTypes(def1,def2 : tdef) : boolean;
  1580. var
  1581. s1,s2 : string;
  1582. begin
  1583. if not is_equal(def1,def2) then
  1584. begin
  1585. { Crash prevention }
  1586. if (not assigned(def1)) or (not assigned(def2)) then
  1587. Message(type_e_mismatch)
  1588. else
  1589. begin
  1590. s1:=def1.typename;
  1591. s2:=def2.typename;
  1592. if (s1<>'<unknown type>') and (s2<>'<unknown type>') then
  1593. Message2(type_e_not_equal_types,def1.typename,def2.typename)
  1594. else
  1595. Message(type_e_mismatch);
  1596. end;
  1597. CheckTypes:=false;
  1598. end
  1599. else
  1600. CheckTypes:=true;
  1601. end;
  1602. end.
  1603. {
  1604. $Log$
  1605. Revision 1.45 2001-08-19 21:11:21 florian
  1606. * some bugs fix:
  1607. - overload; with external procedures fixed
  1608. - better selection of routine to do an overloaded
  1609. type case
  1610. - ... some more
  1611. Revision 1.44 2001/07/08 21:00:16 peter
  1612. * various widestring updates, it works now mostly without charset
  1613. mapping supported
  1614. Revision 1.43 2001/06/29 14:16:57 jonas
  1615. * fixed inconsistent handling of procvars in FPC mode (sometimes @ was
  1616. required to assign the address of a procedure to a procvar, sometimes
  1617. not. Now it is always required) (merged)
  1618. Revision 1.42 2001/05/08 21:06:33 florian
  1619. * some more support for widechars commited especially
  1620. regarding type casting and constants
  1621. Revision 1.41 2001/04/22 22:46:49 florian
  1622. * more variant support
  1623. Revision 1.40 2001/04/18 22:02:00 peter
  1624. * registration of targets and assemblers
  1625. Revision 1.39 2001/04/13 01:22:17 peter
  1626. * symtable change to classes
  1627. * range check generation and errors fixed, make cycle DEBUG=1 works
  1628. * memory leaks fixed
  1629. Revision 1.38 2001/04/04 21:30:47 florian
  1630. * applied several fixes to get the DD8 Delphi Unit compiled
  1631. e.g. "forward"-interfaces are working now
  1632. Revision 1.37 2001/04/02 21:20:35 peter
  1633. * resulttype rewrite
  1634. Revision 1.36 2001/03/23 00:16:07 florian
  1635. + some stuff to compile FreeCLX added
  1636. Revision 1.35 2001/03/03 12:38:33 jonas
  1637. + support for arraydefs in is_signed (for their rangetype, used in rangechecks)
  1638. Revision 1.34 2001/02/26 19:44:55 peter
  1639. * merged generic m68k updates from fixes branch
  1640. Revision 1.33 2001/02/26 12:47:46 jonas
  1641. * fixed bug in type checking for compatibility of set elements (merged)
  1642. * released fix in options.pas from Carl also for FPC (merged)
  1643. Revision 1.32 2001/02/20 21:44:25 peter
  1644. * tvarrec -> array of const fixed
  1645. Revision 1.31 2001/01/22 11:20:15 jonas
  1646. * fixed web bug 1363 (merged)
  1647. Revision 1.30 2001/01/08 21:43:38 peter
  1648. * string isn't compatible with array of char
  1649. Revision 1.29 2000/12/25 00:07:30 peter
  1650. + new tlinkedlist class (merge of old tstringqueue,tcontainer and
  1651. tlinkedlist objects)
  1652. Revision 1.28 2000/12/22 22:38:12 peter
  1653. * fixed bug #1286
  1654. Revision 1.27 2000/12/20 15:59:40 jonas
  1655. - removed obsolete special case for range checking of cardinal constants
  1656. at compile time
  1657. Revision 1.26 2000/12/11 19:13:54 jonas
  1658. * fixed range checking of cardinal constants
  1659. * fixed range checking of "qword constants" (they don't really exist,
  1660. but values > high(int64) were set to zero if assigned to qword)
  1661. Revision 1.25 2000/12/08 14:06:11 jonas
  1662. * fix for web bug 1245: arrays of char with size >255 are now passed to
  1663. overloaded procedures which expect ansistrings instead of shortstrings
  1664. if possible
  1665. * pointer to array of chars (when using $t+) are now also considered
  1666. pchars
  1667. Revision 1.24 2000/11/20 15:52:47 jonas
  1668. * testrange now always cuts a constant to the size of the destination
  1669. if a rangeerror occurred
  1670. * changed an "and $ffffffff" to "and (int64($fffffff) shl 4 + $f" to
  1671. work around the constant evaluation problem we currently have
  1672. Revision 1.23 2000/11/13 14:42:41 jonas
  1673. * fix in testrange so that 64bit constants are properly truncated when
  1674. assigned to 32bit vars
  1675. Revision 1.22 2000/11/13 11:30:55 florian
  1676. * some bugs with interfaces and NIL fixed
  1677. Revision 1.21 2000/11/12 23:24:12 florian
  1678. * interfaces are basically running
  1679. Revision 1.20 2000/11/11 16:13:31 peter
  1680. * farpointer and normal pointer aren't compatible
  1681. Revision 1.19 2000/11/06 22:30:30 peter
  1682. * more fixes
  1683. Revision 1.18 2000/11/04 14:25:22 florian
  1684. + merged Attila's changes for interfaces, not tested yet
  1685. Revision 1.17 2000/10/31 22:30:13 peter
  1686. * merged asm result patch part 2
  1687. Revision 1.16 2000/10/31 22:02:55 peter
  1688. * symtable splitted, no real code changes
  1689. Revision 1.15 2000/10/21 18:16:12 florian
  1690. * a lot of changes:
  1691. - basic dyn. array support
  1692. - basic C++ support
  1693. - some work for interfaces done
  1694. ....
  1695. Revision 1.14 2000/10/14 10:14:56 peter
  1696. * moehrendorf oct 2000 rewrite
  1697. Revision 1.13 2000/10/01 19:48:26 peter
  1698. * lot of compile updates for cg11
  1699. Revision 1.12 2000/09/30 16:08:46 peter
  1700. * more cg11 updates
  1701. Revision 1.11 2000/09/24 15:06:32 peter
  1702. * use defines.inc
  1703. Revision 1.10 2000/09/18 12:31:15 jonas
  1704. * fixed bug in push_addr_param for arrays (merged from fixes branch)
  1705. Revision 1.9 2000/09/10 20:16:21 peter
  1706. * array of const isn't equal with array of <type> (merged)
  1707. Revision 1.8 2000/08/19 19:51:03 peter
  1708. * fixed bug with comparing constsym strings
  1709. Revision 1.7 2000/08/16 13:06:07 florian
  1710. + support of 64 bit integer constants
  1711. Revision 1.6 2000/08/13 13:07:18 peter
  1712. * equal_paras now also checks default parameter value
  1713. Revision 1.5 2000/08/12 06:49:22 florian
  1714. + case statement for int64/qword implemented
  1715. Revision 1.4 2000/08/08 19:26:41 peter
  1716. * equal_constsym() needed for default para
  1717. Revision 1.3 2000/07/13 12:08:28 michael
  1718. + patched to 1.1.0 with former 1.09patch from peter
  1719. Revision 1.2 2000/07/13 11:32:53 michael
  1720. + removed logs
  1721. }