ncnv.pas 102 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899
  1. {
  2. Copyright (c) 2000-2002 by Florian Klaempfl
  3. Type checking and register allocation for type converting nodes
  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 ncnv;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. node,
  22. symtype,
  23. defutil,defcmp,
  24. nld
  25. ;
  26. type
  27. ttypeconvnode = class(tunarynode)
  28. totype : ttype;
  29. convtype : tconverttype;
  30. constructor create(node : tnode;const t : ttype);virtual;
  31. constructor create_explicit(node : tnode;const t : ttype);
  32. constructor create_internal(node : tnode;const t : ttype);
  33. constructor create_proc_to_procvar(node : tnode);
  34. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  35. procedure ppuwrite(ppufile:tcompilerppufile);override;
  36. procedure buildderefimpl;override;
  37. procedure derefimpl;override;
  38. function _getcopy : tnode;override;
  39. procedure printnodeinfo(var t : text);override;
  40. function pass_1 : tnode;override;
  41. function det_resulttype:tnode;override;
  42. function simplify:tnode; override;
  43. procedure mark_write;override;
  44. function docompare(p: tnode) : boolean; override;
  45. function assign_allowed:boolean;
  46. procedure second_call_helper(c : tconverttype);
  47. private
  48. function resulttype_int_to_int : tnode;
  49. function resulttype_cord_to_pointer : tnode;
  50. function resulttype_chararray_to_string : tnode;
  51. function resulttype_string_to_chararray : tnode;
  52. function resulttype_string_to_string : tnode;
  53. function resulttype_char_to_string : tnode;
  54. function resulttype_char_to_chararray : tnode;
  55. function resulttype_int_to_real : tnode;
  56. function resulttype_int_to_string : tnode;
  57. function resulttype_real_to_real : tnode;
  58. function resulttype_real_to_currency : tnode;
  59. function resulttype_cchar_to_pchar : tnode;
  60. function resulttype_cstring_to_pchar : tnode;
  61. function resulttype_cstring_to_int : tnode;
  62. function resulttype_char_to_char : tnode;
  63. function resulttype_arrayconstructor_to_set : tnode;
  64. function resulttype_pchar_to_string : tnode;
  65. function resulttype_interface_to_guid : tnode;
  66. function resulttype_dynarray_to_openarray : tnode;
  67. function resulttype_pwchar_to_string : tnode;
  68. function resulttype_variant_to_dynarray : tnode;
  69. function resulttype_dynarray_to_variant : tnode;
  70. function resulttype_call_helper(c : tconverttype) : tnode;
  71. function resulttype_variant_to_enum : tnode;
  72. function resulttype_enum_to_variant : tnode;
  73. function resulttype_proc_to_procvar : tnode;
  74. function resulttype_variant_to_interface : tnode;
  75. function resulttype_interface_to_variant : tnode;
  76. function resulttype_array_2_dynarray : tnode;
  77. protected
  78. function first_int_to_int : tnode;virtual;
  79. function first_cstring_to_pchar : tnode;virtual;
  80. function first_cstring_to_int : tnode;virtual;
  81. function first_string_to_chararray : tnode;virtual;
  82. function first_char_to_string : tnode;virtual;
  83. function first_nothing : tnode;virtual;
  84. function first_array_to_pointer : tnode;virtual;
  85. function first_int_to_real : tnode;virtual;
  86. function first_real_to_real : tnode;virtual;
  87. function first_pointer_to_array : tnode;virtual;
  88. function first_cchar_to_pchar : tnode;virtual;
  89. function first_bool_to_int : tnode;virtual;
  90. function first_int_to_bool : tnode;virtual;
  91. function first_bool_to_bool : tnode;virtual;
  92. function first_proc_to_procvar : tnode;virtual;
  93. function first_load_smallset : tnode;virtual;
  94. function first_cord_to_pointer : tnode;virtual;
  95. function first_ansistring_to_pchar : tnode;virtual;
  96. function first_arrayconstructor_to_set : tnode;virtual;
  97. function first_class_to_intf : tnode;virtual;
  98. function first_char_to_char : tnode;virtual;
  99. function first_call_helper(c : tconverttype) : tnode;
  100. { these wrapper are necessary, because the first_* stuff is called }
  101. { through a table. Without the wrappers override wouldn't have }
  102. { any effect }
  103. function _first_int_to_int : tnode;
  104. function _first_cstring_to_pchar : tnode;
  105. function _first_cstring_to_int : tnode;
  106. function _first_string_to_chararray : tnode;
  107. function _first_char_to_string : tnode;
  108. function _first_nothing : tnode;
  109. function _first_array_to_pointer : tnode;
  110. function _first_int_to_real : tnode;
  111. function _first_real_to_real: tnode;
  112. function _first_pointer_to_array : tnode;
  113. function _first_cchar_to_pchar : tnode;
  114. function _first_bool_to_int : tnode;
  115. function _first_int_to_bool : tnode;
  116. function _first_bool_to_bool : tnode;
  117. function _first_proc_to_procvar : tnode;
  118. function _first_load_smallset : tnode;
  119. function _first_cord_to_pointer : tnode;
  120. function _first_ansistring_to_pchar : tnode;
  121. function _first_arrayconstructor_to_set : tnode;
  122. function _first_class_to_intf : tnode;
  123. function _first_char_to_char : tnode;
  124. procedure _second_int_to_int;virtual;
  125. procedure _second_string_to_string;virtual;
  126. procedure _second_cstring_to_pchar;virtual;
  127. procedure _second_cstring_to_int;virtual;
  128. procedure _second_string_to_chararray;virtual;
  129. procedure _second_array_to_pointer;virtual;
  130. procedure _second_pointer_to_array;virtual;
  131. procedure _second_chararray_to_string;virtual;
  132. procedure _second_char_to_string;virtual;
  133. procedure _second_int_to_real;virtual;
  134. procedure _second_real_to_real;virtual;
  135. procedure _second_cord_to_pointer;virtual;
  136. procedure _second_proc_to_procvar;virtual;
  137. procedure _second_bool_to_int;virtual;
  138. procedure _second_int_to_bool;virtual;
  139. procedure _second_bool_to_bool;virtual;
  140. procedure _second_load_smallset;virtual;
  141. procedure _second_ansistring_to_pchar;virtual;
  142. procedure _second_class_to_intf;virtual;
  143. procedure _second_char_to_char;virtual;
  144. procedure _second_nothing; virtual;
  145. procedure second_int_to_int;virtual;abstract;
  146. procedure second_string_to_string;virtual;abstract;
  147. procedure second_cstring_to_pchar;virtual;abstract;
  148. procedure second_cstring_to_int;virtual;abstract;
  149. procedure second_string_to_chararray;virtual;abstract;
  150. procedure second_array_to_pointer;virtual;abstract;
  151. procedure second_pointer_to_array;virtual;abstract;
  152. procedure second_chararray_to_string;virtual;abstract;
  153. procedure second_char_to_string;virtual;abstract;
  154. procedure second_int_to_real;virtual;abstract;
  155. procedure second_real_to_real;virtual;abstract;
  156. procedure second_cord_to_pointer;virtual;abstract;
  157. procedure second_proc_to_procvar;virtual;abstract;
  158. procedure second_bool_to_int;virtual;abstract;
  159. procedure second_int_to_bool;virtual;abstract;
  160. procedure second_bool_to_bool;virtual;abstract;
  161. procedure second_load_smallset;virtual;abstract;
  162. procedure second_ansistring_to_pchar;virtual;abstract;
  163. procedure second_class_to_intf;virtual;abstract;
  164. procedure second_char_to_char;virtual;abstract;
  165. procedure second_nothing; virtual;abstract;
  166. end;
  167. ttypeconvnodeclass = class of ttypeconvnode;
  168. tasnode = class(tbinarynode)
  169. constructor create(l,r : tnode);virtual;
  170. function pass_1 : tnode;override;
  171. function det_resulttype:tnode;override;
  172. function _getcopy: tnode;override;
  173. destructor destroy; override;
  174. call: tnode;
  175. end;
  176. tasnodeclass = class of tasnode;
  177. tisnode = class(tbinarynode)
  178. constructor create(l,r : tnode);virtual;
  179. function pass_1 : tnode;override;
  180. function det_resulttype:tnode;override;
  181. procedure pass_2;override;
  182. end;
  183. tisnodeclass = class of tisnode;
  184. var
  185. ctypeconvnode : ttypeconvnodeclass;
  186. casnode : tasnodeclass;
  187. cisnode : tisnodeclass;
  188. procedure inserttypeconv(var p:tnode;const t:ttype);
  189. procedure inserttypeconv_internal(var p:tnode;const t:ttype);
  190. procedure arrayconstructor_to_set(var p : tnode);
  191. procedure insert_varargstypeconv(var p : tnode; iscvarargs: boolean);
  192. procedure int_to_4cc(var p: tnode);
  193. implementation
  194. uses
  195. cclasses,globtype,systems,
  196. cutils,verbose,globals,widestr,
  197. symconst,symdef,symsym,symbase,symtable,
  198. ncon,ncal,nset,nadd,ninl,nmem,nmat,nbas,nutils,
  199. cgbase,procinfo,
  200. htypechk,pass_1,cpuinfo;
  201. {*****************************************************************************
  202. Helpers
  203. *****************************************************************************}
  204. procedure inserttypeconv(var p:tnode;const t:ttype);
  205. begin
  206. if not assigned(p.resulttype.def) then
  207. begin
  208. resulttypepass(p);
  209. if codegenerror then
  210. exit;
  211. end;
  212. { don't insert obsolete type conversions }
  213. if equal_defs(p.resulttype.def,t.def) and
  214. not ((p.resulttype.def.deftype=setdef) and
  215. (tsetdef(p.resulttype.def).settype <>
  216. tsetdef(t.def).settype)) then
  217. begin
  218. p.resulttype:=t;
  219. end
  220. else
  221. begin
  222. p:=ctypeconvnode.create(p,t);
  223. resulttypepass(p);
  224. end;
  225. end;
  226. procedure inserttypeconv_internal(var p:tnode;const t:ttype);
  227. begin
  228. if not assigned(p.resulttype.def) then
  229. begin
  230. resulttypepass(p);
  231. if codegenerror then
  232. exit;
  233. end;
  234. { don't insert obsolete type conversions }
  235. if equal_defs(p.resulttype.def,t.def) and
  236. not ((p.resulttype.def.deftype=setdef) and
  237. (tsetdef(p.resulttype.def).settype <>
  238. tsetdef(t.def).settype)) then
  239. begin
  240. p.resulttype:=t;
  241. end
  242. else
  243. begin
  244. p:=ctypeconvnode.create_internal(p,t);
  245. resulttypepass(p);
  246. end;
  247. end;
  248. {*****************************************************************************
  249. Array constructor to Set Conversion
  250. *****************************************************************************}
  251. procedure arrayconstructor_to_set(var p : tnode);
  252. var
  253. constp : tsetconstnode;
  254. buildp,
  255. p2,p3,p4 : tnode;
  256. htype : ttype;
  257. constset : Pconstset;
  258. constsetlo,
  259. constsethi : TConstExprInt;
  260. procedure update_constsethi(t:ttype);
  261. begin
  262. if ((t.def.deftype=orddef) and
  263. (torddef(t.def).high>=constsethi)) then
  264. begin
  265. if torddef(t.def).typ=uwidechar then
  266. begin
  267. constsethi:=255;
  268. if htype.def=nil then
  269. htype:=t;
  270. end
  271. else
  272. begin
  273. constsethi:=torddef(t.def).high;
  274. if htype.def=nil then
  275. begin
  276. if (constsethi>255) or
  277. (torddef(t.def).low<0) then
  278. htype:=u8inttype
  279. else
  280. htype:=t;
  281. end;
  282. if constsethi>255 then
  283. constsethi:=255;
  284. end;
  285. end
  286. else if ((t.def.deftype=enumdef) and
  287. (tenumdef(t.def).max>=constsethi)) then
  288. begin
  289. if htype.def=nil then
  290. htype:=t;
  291. constsethi:=tenumdef(t.def).max;
  292. end;
  293. end;
  294. procedure do_set(pos : longint);
  295. begin
  296. if (pos and not $ff)<>0 then
  297. Message(parser_e_illegal_set_expr);
  298. if pos>constsethi then
  299. constsethi:=pos;
  300. if pos<constsetlo then
  301. constsetlo:=pos;
  302. if pos in constset^ then
  303. Message(parser_e_illegal_set_expr);
  304. include(constset^,pos);
  305. end;
  306. var
  307. l : Longint;
  308. lr,hr : TConstExprInt;
  309. hp : tarrayconstructornode;
  310. begin
  311. if p.nodetype<>arrayconstructorn then
  312. internalerror(200205105);
  313. new(constset);
  314. constset^:=[];
  315. htype.reset;
  316. constsetlo:=0;
  317. constsethi:=0;
  318. constp:=csetconstnode.create(nil,htype);
  319. constp.value_set:=constset;
  320. buildp:=constp;
  321. hp:=tarrayconstructornode(p);
  322. if assigned(hp.left) then
  323. begin
  324. while assigned(hp) do
  325. begin
  326. p4:=nil; { will contain the tree to create the set }
  327. {split a range into p2 and p3 }
  328. if hp.left.nodetype=arrayconstructorrangen then
  329. begin
  330. p2:=tarrayconstructorrangenode(hp.left).left;
  331. p3:=tarrayconstructorrangenode(hp.left).right;
  332. tarrayconstructorrangenode(hp.left).left:=nil;
  333. tarrayconstructorrangenode(hp.left).right:=nil;
  334. end
  335. else
  336. begin
  337. p2:=hp.left;
  338. hp.left:=nil;
  339. p3:=nil;
  340. end;
  341. resulttypepass(p2);
  342. set_varstate(p2,vs_read,[vsf_must_be_valid]);
  343. if assigned(p3) then
  344. begin
  345. resulttypepass(p3);
  346. set_varstate(p3,vs_read,[vsf_must_be_valid]);
  347. end;
  348. if codegenerror then
  349. break;
  350. case p2.resulttype.def.deftype of
  351. enumdef,
  352. orddef:
  353. begin
  354. getrange(p2.resulttype.def,lr,hr);
  355. if assigned(p3) then
  356. begin
  357. { this isn't good, you'll get problems with
  358. type t010 = 0..10;
  359. ts = set of t010;
  360. var s : ts;b : t010
  361. begin s:=[1,2,b]; end.
  362. if is_integer(p3^.resulttype.def) then
  363. begin
  364. inserttypeconv(p3,u8bitdef);
  365. end;
  366. }
  367. if assigned(htype.def) and not(equal_defs(htype.def,p3.resulttype.def)) then
  368. begin
  369. aktfilepos:=p3.fileinfo;
  370. CGMessage(type_e_typeconflict_in_set);
  371. end
  372. else
  373. begin
  374. if (p2.nodetype=ordconstn) and (p3.nodetype=ordconstn) then
  375. begin
  376. if not(is_integer(p3.resulttype.def)) then
  377. htype:=p3.resulttype
  378. else
  379. begin
  380. inserttypeconv(p3,u8inttype);
  381. inserttypeconv(p2,u8inttype);
  382. end;
  383. for l:=tordconstnode(p2).value to tordconstnode(p3).value do
  384. do_set(l);
  385. p2.free;
  386. p3.free;
  387. end
  388. else
  389. begin
  390. update_constsethi(p2.resulttype);
  391. inserttypeconv(p2,htype);
  392. update_constsethi(p3.resulttype);
  393. inserttypeconv(p3,htype);
  394. if assigned(htype.def) then
  395. inserttypeconv(p3,htype)
  396. else
  397. inserttypeconv(p3,u8inttype);
  398. p4:=csetelementnode.create(p2,p3);
  399. end;
  400. end;
  401. end
  402. else
  403. begin
  404. { Single value }
  405. if p2.nodetype=ordconstn then
  406. begin
  407. if not(is_integer(p2.resulttype.def)) then
  408. begin
  409. { for constant set elements, delphi allows the usage of elements of enumerations which
  410. have value>255 if there is no element with a value > 255 used }
  411. if (m_delphi in aktmodeswitches) and (p2.resulttype.def.deftype=enumdef) then
  412. begin
  413. if tordconstnode(p2).value>constsethi then
  414. constsethi:=tordconstnode(p2).value;
  415. if htype.def=nil then
  416. htype:=p2.resulttype;
  417. end
  418. else
  419. update_constsethi(p2.resulttype);
  420. end;
  421. if assigned(htype.def) then
  422. inserttypeconv(p2,htype)
  423. else
  424. inserttypeconv(p2,u8inttype);
  425. do_set(tordconstnode(p2).value);
  426. p2.free;
  427. end
  428. else
  429. begin
  430. update_constsethi(p2.resulttype);
  431. if assigned(htype.def) then
  432. inserttypeconv(p2,htype)
  433. else
  434. inserttypeconv(p2,u8inttype);
  435. p4:=csetelementnode.create(p2,nil);
  436. end;
  437. end;
  438. end;
  439. stringdef :
  440. begin
  441. { if we've already set elements which are constants }
  442. { throw an error }
  443. if ((htype.def=nil) and assigned(buildp)) or
  444. not(is_char(htype.def)) then
  445. CGMessage(type_e_typeconflict_in_set)
  446. else
  447. for l:=1 to length(pstring(tstringconstnode(p2).value_str)^) do
  448. do_set(ord(pstring(tstringconstnode(p2).value_str)^[l]));
  449. if htype.def=nil then
  450. htype:=cchartype;
  451. p2.free;
  452. end;
  453. else
  454. CGMessage(type_e_ordinal_expr_expected);
  455. end;
  456. { insert the set creation tree }
  457. if assigned(p4) then
  458. buildp:=caddnode.create(addn,buildp,p4);
  459. { load next and dispose current node }
  460. p2:=hp;
  461. hp:=tarrayconstructornode(tarrayconstructornode(p2).right);
  462. tarrayconstructornode(p2).right:=nil;
  463. p2.free;
  464. end;
  465. if (htype.def=nil) then
  466. htype:=u8inttype;
  467. end
  468. else
  469. begin
  470. { empty set [], only remove node }
  471. p.free;
  472. end;
  473. { set the initial set type }
  474. constp.resulttype.setdef(tsetdef.create(htype,constsethi));
  475. { determine the resulttype for the tree }
  476. resulttypepass(buildp);
  477. { set the new tree }
  478. p:=buildp;
  479. end;
  480. procedure insert_varargstypeconv(var p : tnode; iscvarargs: boolean);
  481. begin
  482. if not(iscvarargs) and
  483. (p.nodetype=stringconstn) then
  484. p:=ctypeconvnode.create_internal(p,cansistringtype)
  485. else
  486. case p.resulttype.def.deftype of
  487. enumdef :
  488. p:=ctypeconvnode.create_internal(p,s32inttype);
  489. arraydef :
  490. begin
  491. if is_chararray(p.resulttype.def) then
  492. p:=ctypeconvnode.create_internal(p,charpointertype)
  493. else
  494. if is_widechararray(p.resulttype.def) then
  495. p:=ctypeconvnode.create_internal(p,widecharpointertype)
  496. else
  497. CGMessagePos1(p.fileinfo,type_e_wrong_type_in_array_constructor,p.resulttype.def.typename);
  498. end;
  499. orddef :
  500. begin
  501. if is_integer(p.resulttype.def) and
  502. not(is_64bitint(p.resulttype.def)) then
  503. p:=ctypeconvnode.create(p,s32inttype)
  504. else if is_void(p.resulttype.def) then
  505. CGMessagePos1(p.fileinfo,type_e_wrong_type_in_array_constructor,p.resulttype.def.typename)
  506. else if iscvarargs and
  507. is_currency(p.resulttype.def) then
  508. p:=ctypeconvnode.create(p,s64floattype);
  509. end;
  510. floatdef :
  511. if not(iscvarargs) then
  512. begin
  513. if not(is_currency(p.resulttype.def)) then
  514. p:=ctypeconvnode.create(p,pbestrealtype^);
  515. end
  516. else
  517. begin
  518. if is_constrealnode(p) and
  519. not(nf_explicit in p.flags) then
  520. MessagePos(p.fileinfo,type_w_double_c_varargs);
  521. if (tfloatdef(p.resulttype.def).typ in [{$ifndef x86_64}s32real,{$endif}s64currency]) or
  522. (is_constrealnode(p) and
  523. not(nf_explicit in p.flags)) then
  524. p:=ctypeconvnode.create(p,s64floattype);
  525. end;
  526. procvardef :
  527. p:=ctypeconvnode.create(p,voidpointertype);
  528. stringdef:
  529. if iscvarargs then
  530. p:=ctypeconvnode.create(p,charpointertype);
  531. variantdef:
  532. if iscvarargs then
  533. CGMessagePos1(p.fileinfo,type_e_wrong_type_in_array_constructor,p.resulttype.def.typename);
  534. pointerdef:
  535. ;
  536. classrefdef:
  537. if iscvarargs then
  538. p:=ctypeconvnode.create(p,voidpointertype);
  539. objectdef :
  540. if iscvarargs or
  541. is_object(p.resulttype.def) then
  542. CGMessagePos1(p.fileinfo,type_e_wrong_type_in_array_constructor,p.resulttype.def.typename);
  543. else
  544. CGMessagePos1(p.fileinfo,type_e_wrong_type_in_array_constructor,p.resulttype.def.typename);
  545. end;
  546. resulttypepass(p);
  547. end;
  548. procedure int_to_4cc(var p: tnode);
  549. var
  550. srsym: tsym;
  551. srsymtable: tsymtable;
  552. begin
  553. if (m_mac in aktmodeswitches) and
  554. is_integer(p.resulttype.def) and
  555. (p.resulttype.def.size = 4) then
  556. begin
  557. if not searchsym_type('FPC_INTERNAL_FOUR_CHAR_ARRAY',srsym,srsymtable) then
  558. internalerror(2006101802);
  559. inserttypeconv_internal(p,ttypesym(srsym).restype);
  560. end
  561. else
  562. internalerror(2006101803);
  563. end;
  564. {*****************************************************************************
  565. TTYPECONVNODE
  566. *****************************************************************************}
  567. constructor ttypeconvnode.create(node : tnode;const t:ttype);
  568. begin
  569. inherited create(typeconvn,node);
  570. convtype:=tc_none;
  571. totype:=t;
  572. if t.def=nil then
  573. internalerror(200103281);
  574. fileinfo:=node.fileinfo;
  575. end;
  576. constructor ttypeconvnode.create_explicit(node : tnode;const t:ttype);
  577. begin
  578. self.create(node,t);
  579. include(flags,nf_explicit);
  580. end;
  581. constructor ttypeconvnode.create_internal(node : tnode;const t:ttype);
  582. begin
  583. self.create(node,t);
  584. { handle like explicit conversions }
  585. include(flags,nf_explicit);
  586. include(flags,nf_internal);
  587. end;
  588. constructor ttypeconvnode.create_proc_to_procvar(node : tnode);
  589. begin
  590. self.create(node,voidtype);
  591. convtype:=tc_proc_2_procvar;
  592. end;
  593. constructor ttypeconvnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  594. begin
  595. inherited ppuload(t,ppufile);
  596. ppufile.gettype(totype);
  597. convtype:=tconverttype(ppufile.getbyte);
  598. end;
  599. procedure ttypeconvnode.ppuwrite(ppufile:tcompilerppufile);
  600. begin
  601. inherited ppuwrite(ppufile);
  602. ppufile.puttype(totype);
  603. ppufile.putbyte(byte(convtype));
  604. end;
  605. procedure ttypeconvnode.buildderefimpl;
  606. begin
  607. inherited buildderefimpl;
  608. totype.buildderef;
  609. end;
  610. procedure ttypeconvnode.derefimpl;
  611. begin
  612. inherited derefimpl;
  613. totype.resolve;
  614. end;
  615. function ttypeconvnode._getcopy : tnode;
  616. var
  617. n : ttypeconvnode;
  618. begin
  619. n:=ttypeconvnode(inherited _getcopy);
  620. n.convtype:=convtype;
  621. n.totype:=totype;
  622. _getcopy:=n;
  623. end;
  624. procedure ttypeconvnode.printnodeinfo(var t : text);
  625. const
  626. convtyp2str : array[tconverttype] of pchar = (
  627. 'tc_none',
  628. 'tc_equal',
  629. 'tc_not_possible',
  630. 'tc_string_2_string',
  631. 'tc_char_2_string',
  632. 'tc_char_2_chararray',
  633. 'tc_pchar_2_string',
  634. 'tc_cchar_2_pchar',
  635. 'tc_cstring_2_pchar',
  636. 'tc_cstring_2_int',
  637. 'tc_ansistring_2_pchar',
  638. 'tc_string_2_chararray',
  639. 'tc_chararray_2_string',
  640. 'tc_array_2_pointer',
  641. 'tc_pointer_2_array',
  642. 'tc_int_2_int',
  643. 'tc_int_2_bool',
  644. 'tc_int_2_string',
  645. 'tc_bool_2_bool',
  646. 'tc_bool_2_int',
  647. 'tc_real_2_real',
  648. 'tc_int_2_real',
  649. 'tc_real_2_currency',
  650. 'tc_proc_2_procvar',
  651. 'tc_arrayconstructor_2_set',
  652. 'tc_load_smallset',
  653. 'tc_cord_2_pointer',
  654. 'tc_intf_2_string',
  655. 'tc_intf_2_guid',
  656. 'tc_class_2_intf',
  657. 'tc_char_2_char',
  658. 'tc_normal_2_smallset',
  659. 'tc_dynarray_2_openarray',
  660. 'tc_pwchar_2_string',
  661. 'tc_variant_2_dynarray',
  662. 'tc_dynarray_2_variant',
  663. 'tc_variant_2_enum',
  664. 'tc_enum_2_variant',
  665. 'tc_interface_2_variant',
  666. 'tc_variant_2_interface',
  667. 'tc_array_2_dynarray'
  668. );
  669. begin
  670. inherited printnodeinfo(t);
  671. write(t,', convtype = ',strpas(convtyp2str[convtype]));
  672. end;
  673. function ttypeconvnode.resulttype_cord_to_pointer : tnode;
  674. var
  675. t : tnode;
  676. begin
  677. result:=nil;
  678. if left.nodetype=ordconstn then
  679. begin
  680. { check if we have a valid pointer constant (JM) }
  681. if (sizeof(pointer) > sizeof(TConstPtrUInt)) then
  682. if (sizeof(TConstPtrUInt) = 4) then
  683. begin
  684. if (tordconstnode(left).value < low(longint)) or
  685. (tordconstnode(left).value > high(cardinal)) then
  686. CGMessage(parser_e_range_check_error);
  687. end
  688. else if (sizeof(TConstPtrUInt) = 8) then
  689. begin
  690. if (tordconstnode(left).value < low(int64)) or
  691. (tordconstnode(left).value > high(qword)) then
  692. CGMessage(parser_e_range_check_error);
  693. end
  694. else
  695. internalerror(2001020801);
  696. t:=cpointerconstnode.create(TConstPtrUInt(tordconstnode(left).value),resulttype);
  697. result:=t;
  698. end
  699. else
  700. internalerror(200104023);
  701. end;
  702. function ttypeconvnode.resulttype_chararray_to_string : tnode;
  703. var
  704. chartype : string[8];
  705. begin
  706. if is_widechar(tarraydef(left.resulttype.def).elementtype.def) then
  707. chartype:='widechar'
  708. else
  709. chartype:='char';
  710. result := ccallnode.createinternres(
  711. 'fpc_'+chartype+'array_to_'+tstringdef(resulttype.def).stringtypname,
  712. ccallparanode.create(cordconstnode.create(
  713. ord(tarraydef(left.resulttype.def).lowrange=0),booltype,false),
  714. ccallparanode.create(left,nil)),resulttype);
  715. left := nil;
  716. end;
  717. function ttypeconvnode.resulttype_string_to_chararray : tnode;
  718. var
  719. arrsize : aint;
  720. chartype : string[8];
  721. begin
  722. result := nil;
  723. with tarraydef(resulttype.def) do
  724. begin
  725. if highrange<lowrange then
  726. internalerror(200501051);
  727. arrsize := highrange-lowrange+1;
  728. end;
  729. if (left.nodetype = stringconstn) and
  730. (tstringconstnode(left).cst_type=cst_conststring) then
  731. begin
  732. { if the array of char is large enough we can use the string
  733. constant directly. This is handled in ncgcnv }
  734. if (arrsize>=tstringconstnode(left).len) and
  735. is_char(tarraydef(resulttype.def).elementtype.def) then
  736. exit;
  737. { Convert to wide/short/ansistring and call default helper }
  738. if is_widechar(tarraydef(resulttype.def).elementtype.def) then
  739. inserttypeconv(left,cwidestringtype)
  740. else
  741. begin
  742. if tstringconstnode(left).len>255 then
  743. inserttypeconv(left,cansistringtype)
  744. else
  745. inserttypeconv(left,cshortstringtype);
  746. end;
  747. end;
  748. if is_widechar(tarraydef(resulttype.def).elementtype.def) then
  749. chartype:='widechar'
  750. else
  751. chartype:='char';
  752. result := ccallnode.createinternres(
  753. 'fpc_'+tstringdef(left.resulttype.def).stringtypname+
  754. '_to_'+chartype+'array',ccallparanode.create(left,ccallparanode.create(
  755. cordconstnode.create(arrsize,s32inttype,true),nil)),resulttype);
  756. left := nil;
  757. end;
  758. function ttypeconvnode.resulttype_string_to_string : tnode;
  759. var
  760. procname: string[31];
  761. stringpara : tcallparanode;
  762. begin
  763. result:=nil;
  764. if left.nodetype=stringconstn then
  765. begin
  766. tstringconstnode(left).changestringtype(resulttype);
  767. result:=left;
  768. left:=nil;
  769. end
  770. else
  771. begin
  772. { get the correct procedure name }
  773. procname := 'fpc_'+tstringdef(left.resulttype.def).stringtypname+
  774. '_to_'+tstringdef(resulttype.def).stringtypname;
  775. { create parameter (and remove left node from typeconvnode }
  776. { since it's reused as parameter) }
  777. stringpara := ccallparanode.create(left,nil);
  778. left := nil;
  779. { when converting to shortstrings, we have to pass high(destination) too }
  780. if (tstringdef(resulttype.def).string_typ = st_shortstring) then
  781. stringpara.right := ccallparanode.create(cinlinenode.create(
  782. in_high_x,false,self.getcopy),nil);
  783. { and create the callnode }
  784. result := ccallnode.createinternres(procname,stringpara,resulttype);
  785. end;
  786. end;
  787. function ttypeconvnode.resulttype_char_to_string : tnode;
  788. var
  789. procname: string[31];
  790. para : tcallparanode;
  791. hp : tstringconstnode;
  792. ws : pcompilerwidestring;
  793. begin
  794. result:=nil;
  795. if left.nodetype=ordconstn then
  796. begin
  797. if tstringdef(resulttype.def).string_typ=st_widestring then
  798. begin
  799. initwidestring(ws);
  800. if torddef(left.resulttype.def).typ=uwidechar then
  801. concatwidestringchar(ws,tcompilerwidechar(tordconstnode(left).value))
  802. else
  803. concatwidestringchar(ws,tcompilerwidechar(chr(tordconstnode(left).value)));
  804. hp:=cstringconstnode.createwstr(ws);
  805. donewidestring(ws);
  806. end
  807. else
  808. begin
  809. hp:=cstringconstnode.createstr(chr(tordconstnode(left).value));
  810. tstringconstnode(hp).changestringtype(resulttype);
  811. end;
  812. result:=hp;
  813. end
  814. else
  815. { shortstrings are handled 'inline' }
  816. if tstringdef(resulttype.def).string_typ <> st_shortstring then
  817. begin
  818. { create the parameter }
  819. para := ccallparanode.create(left,nil);
  820. left := nil;
  821. { and the procname }
  822. procname := 'fpc_char_to_' +tstringdef(resulttype.def).stringtypname;
  823. { and finally the call }
  824. result := ccallnode.createinternres(procname,para,resulttype);
  825. end
  826. else
  827. begin
  828. { create word(byte(char) shl 8 or 1) for litte endian machines }
  829. { and word(byte(char) or 256) for big endian machines }
  830. left := ctypeconvnode.create_internal(left,u8inttype);
  831. if (target_info.endian = endian_little) then
  832. left := caddnode.create(orn,
  833. cshlshrnode.create(shln,left,cordconstnode.create(8,s32inttype,false)),
  834. cordconstnode.create(1,s32inttype,false))
  835. else
  836. left := caddnode.create(orn,left,
  837. cordconstnode.create(1 shl 8,s32inttype,false));
  838. left := ctypeconvnode.create_internal(left,u16inttype);
  839. resulttypepass(left);
  840. end;
  841. end;
  842. function ttypeconvnode.resulttype_char_to_chararray : tnode;
  843. begin
  844. if resulttype.def.size <> 1 then
  845. begin
  846. { convert first to string, then to chararray }
  847. inserttypeconv(left,cshortstringtype);
  848. inserttypeconv(left,resulttype);
  849. result:=left;
  850. left := nil;
  851. exit;
  852. end;
  853. result := nil;
  854. end;
  855. function ttypeconvnode.resulttype_char_to_char : tnode;
  856. var
  857. hp : tordconstnode;
  858. begin
  859. result:=nil;
  860. if left.nodetype=ordconstn then
  861. begin
  862. if (torddef(resulttype.def).typ=uchar) and
  863. (torddef(left.resulttype.def).typ=uwidechar) then
  864. begin
  865. hp:=cordconstnode.create(
  866. ord(unicode2asciichar(tcompilerwidechar(tordconstnode(left).value))),
  867. cchartype,true);
  868. result:=hp;
  869. end
  870. else if (torddef(resulttype.def).typ=uwidechar) and
  871. (torddef(left.resulttype.def).typ=uchar) then
  872. begin
  873. hp:=cordconstnode.create(
  874. asciichar2unicode(chr(tordconstnode(left).value)),
  875. cwidechartype,true);
  876. result:=hp;
  877. end
  878. else
  879. internalerror(200105131);
  880. exit;
  881. end;
  882. end;
  883. function ttypeconvnode.resulttype_int_to_int : tnode;
  884. var
  885. v : TConstExprInt;
  886. begin
  887. result:=nil;
  888. if left.nodetype=ordconstn then
  889. begin
  890. v:=tordconstnode(left).value;
  891. if is_currency(resulttype.def) then
  892. v:=v*10000;
  893. if (resulttype.def.deftype=pointerdef) then
  894. result:=cpointerconstnode.create(TConstPtrUInt(v),resulttype)
  895. else
  896. begin
  897. if is_currency(left.resulttype.def) then
  898. v:=v div 10000;
  899. result:=cordconstnode.create(v,resulttype,false);
  900. end;
  901. end
  902. else if left.nodetype=pointerconstn then
  903. begin
  904. v:=tpointerconstnode(left).value;
  905. if (resulttype.def.deftype=pointerdef) then
  906. result:=cpointerconstnode.create(v,resulttype)
  907. else
  908. begin
  909. if is_currency(resulttype.def) then
  910. v:=v*10000;
  911. result:=cordconstnode.create(v,resulttype,false);
  912. end;
  913. end
  914. else
  915. begin
  916. { multiply by 10000 for currency. We need to use getcopy to pass
  917. the argument because the current node is always disposed. Only
  918. inserting the multiply in the left node is not possible because
  919. it'll get in an infinite loop to convert int->currency }
  920. if is_currency(resulttype.def) then
  921. begin
  922. result:=caddnode.create(muln,getcopy,cordconstnode.create(10000,resulttype,false));
  923. include(result.flags,nf_is_currency);
  924. end
  925. else if is_currency(left.resulttype.def) then
  926. begin
  927. result:=cmoddivnode.create(divn,getcopy,cordconstnode.create(10000,resulttype,false));
  928. include(result.flags,nf_is_currency);
  929. end;
  930. end;
  931. end;
  932. function ttypeconvnode.resulttype_int_to_real : tnode;
  933. var
  934. rv : bestreal;
  935. begin
  936. result:=nil;
  937. if left.nodetype=ordconstn then
  938. begin
  939. rv:=tordconstnode(left).value;
  940. if is_currency(resulttype.def) then
  941. rv:=rv*10000.0
  942. else if is_currency(left.resulttype.def) then
  943. rv:=rv/10000.0;
  944. result:=crealconstnode.create(rv,resulttype);
  945. end
  946. else
  947. begin
  948. { multiply by 10000 for currency. We need to use getcopy to pass
  949. the argument because the current node is always disposed. Only
  950. inserting the multiply in the left node is not possible because
  951. it'll get in an infinite loop to convert int->currency }
  952. if is_currency(resulttype.def) then
  953. begin
  954. result:=caddnode.create(muln,getcopy,crealconstnode.create(10000.0,resulttype));
  955. include(result.flags,nf_is_currency);
  956. end
  957. else if is_currency(left.resulttype.def) then
  958. begin
  959. result:=caddnode.create(slashn,getcopy,crealconstnode.create(10000.0,resulttype));
  960. include(result.flags,nf_is_currency);
  961. end;
  962. end;
  963. end;
  964. function ttypeconvnode.resulttype_real_to_currency : tnode;
  965. begin
  966. if not is_currency(resulttype.def) then
  967. internalerror(200304221);
  968. result:=nil;
  969. left:=caddnode.create(muln,left,crealconstnode.create(10000.0,left.resulttype));
  970. include(left.flags,nf_is_currency);
  971. resulttypepass(left);
  972. { Convert constants directly, else call Round() }
  973. if left.nodetype=realconstn then
  974. result:=cordconstnode.create(round(trealconstnode(left).value_real),resulttype,false)
  975. else
  976. result:=ccallnode.createinternres('fpc_round_real',
  977. ccallparanode.create(left,nil),resulttype);
  978. left:=nil;
  979. end;
  980. function ttypeconvnode.resulttype_int_to_string : tnode;
  981. begin
  982. if (m_mac in aktmodeswitches) and
  983. is_integer(left.resulttype.def) and
  984. (left.resulttype.def.size = 4) then
  985. begin
  986. int_to_4cc(left);
  987. inserttypeconv(left,resulttype);
  988. result := left;
  989. left := nil;
  990. end
  991. else
  992. internalerror(2006101803);
  993. end;
  994. function ttypeconvnode.resulttype_real_to_real : tnode;
  995. begin
  996. result:=nil;
  997. if is_currency(left.resulttype.def) and not(is_currency(resulttype.def)) then
  998. begin
  999. left:=caddnode.create(slashn,left,crealconstnode.create(10000.0,left.resulttype));
  1000. include(left.flags,nf_is_currency);
  1001. resulttypepass(left);
  1002. end
  1003. else
  1004. if is_currency(resulttype.def) and not(is_currency(left.resulttype.def)) then
  1005. begin
  1006. left:=caddnode.create(muln,left,crealconstnode.create(10000.0,left.resulttype));
  1007. include(left.flags,nf_is_currency);
  1008. resulttypepass(left);
  1009. end;
  1010. end;
  1011. function ttypeconvnode.resulttype_cchar_to_pchar : tnode;
  1012. begin
  1013. result:=nil;
  1014. if is_pwidechar(resulttype.def) then
  1015. inserttypeconv(left,cwidestringtype)
  1016. else
  1017. inserttypeconv(left,cshortstringtype);
  1018. { evaluate again, reset resulttype so the convert_typ
  1019. will be calculated again and cstring_to_pchar will
  1020. be used for futher conversion }
  1021. convtype:=tc_none;
  1022. result:=det_resulttype;
  1023. end;
  1024. function ttypeconvnode.resulttype_cstring_to_pchar : tnode;
  1025. begin
  1026. result:=nil;
  1027. if is_pwidechar(resulttype.def) then
  1028. inserttypeconv(left,cwidestringtype)
  1029. else
  1030. if is_pchar(resulttype.def) and
  1031. is_widestring(left.resulttype.def) then
  1032. inserttypeconv(left,cansistringtype);
  1033. end;
  1034. function ttypeconvnode.resulttype_cstring_to_int : tnode;
  1035. var
  1036. fcc : cardinal;
  1037. pb : pbyte;
  1038. begin
  1039. result:=nil;
  1040. if left.nodetype<>stringconstn then
  1041. internalerror(200510012);
  1042. if tstringconstnode(left).len=4 then
  1043. begin
  1044. pb:=pbyte(tstringconstnode(left).value_str);
  1045. fcc:=(pb[0] shl 24) or (pb[1] shl 16) or (pb[2] shl 8) or pb[3];
  1046. result:=cordconstnode.create(fcc,u32inttype,false);
  1047. end
  1048. else
  1049. CGMessage2(type_e_illegal_type_conversion,left.resulttype.def.gettypename,resulttype.def.gettypename);
  1050. end;
  1051. function ttypeconvnode.resulttype_arrayconstructor_to_set : tnode;
  1052. var
  1053. hp : tnode;
  1054. begin
  1055. result:=nil;
  1056. if left.nodetype<>arrayconstructorn then
  1057. internalerror(5546);
  1058. { remove typeconv node }
  1059. hp:=left;
  1060. left:=nil;
  1061. { create a set constructor tree }
  1062. arrayconstructor_to_set(hp);
  1063. result:=hp;
  1064. end;
  1065. function ttypeconvnode.resulttype_pchar_to_string : tnode;
  1066. begin
  1067. result := ccallnode.createinternres(
  1068. 'fpc_pchar_to_'+tstringdef(resulttype.def).stringtypname,
  1069. ccallparanode.create(left,nil),resulttype);
  1070. left := nil;
  1071. end;
  1072. function ttypeconvnode.resulttype_interface_to_guid : tnode;
  1073. begin
  1074. if assigned(tobjectdef(left.resulttype.def).iidguid) then
  1075. result:=cguidconstnode.create(tobjectdef(left.resulttype.def).iidguid^);
  1076. end;
  1077. function ttypeconvnode.resulttype_dynarray_to_openarray : tnode;
  1078. begin
  1079. { a dynamic array is a pointer to an array, so to convert it to }
  1080. { an open array, we have to dereference it (JM) }
  1081. result := ctypeconvnode.create_internal(left,voidpointertype);
  1082. resulttypepass(result);
  1083. { left is reused }
  1084. left := nil;
  1085. result := cderefnode.create(result);
  1086. include(result.flags,nf_no_checkpointer);
  1087. result.resulttype := resulttype;
  1088. end;
  1089. function ttypeconvnode.resulttype_pwchar_to_string : tnode;
  1090. begin
  1091. result := ccallnode.createinternres(
  1092. 'fpc_pwidechar_to_'+tstringdef(resulttype.def).stringtypname,
  1093. ccallparanode.create(left,nil),resulttype);
  1094. left := nil;
  1095. end;
  1096. function ttypeconvnode.resulttype_variant_to_dynarray : tnode;
  1097. begin
  1098. result := ccallnode.createinternres(
  1099. 'fpc_variant_to_dynarray',
  1100. ccallparanode.create(caddrnode.create_internal(crttinode.create(tstoreddef(resulttype.def),initrtti)),
  1101. ccallparanode.create(left,nil)
  1102. ),resulttype);
  1103. resulttypepass(result);
  1104. left:=nil;
  1105. end;
  1106. function ttypeconvnode.resulttype_dynarray_to_variant : tnode;
  1107. begin
  1108. result := ccallnode.createinternres(
  1109. 'fpc_dynarray_to_variant',
  1110. ccallparanode.create(caddrnode.create_internal(crttinode.create(tstoreddef(left.resulttype.def),initrtti)),
  1111. ccallparanode.create(ctypeconvnode.create_explicit(left,voidpointertype),nil)
  1112. ),resulttype);
  1113. resulttypepass(result);
  1114. left:=nil;
  1115. end;
  1116. function ttypeconvnode.resulttype_variant_to_interface : tnode;
  1117. begin
  1118. result := ccallnode.createinternres(
  1119. 'fpc_variant_to_interface',
  1120. ccallparanode.create(left,nil)
  1121. ,resulttype);
  1122. resulttypepass(result);
  1123. left:=nil;
  1124. end;
  1125. function ttypeconvnode.resulttype_interface_to_variant : tnode;
  1126. begin
  1127. result := ccallnode.createinternres(
  1128. 'fpc_interface_to_variant',
  1129. ccallparanode.create(left,nil)
  1130. ,resulttype);
  1131. resulttypepass(result);
  1132. left:=nil;
  1133. end;
  1134. function ttypeconvnode.resulttype_variant_to_enum : tnode;
  1135. begin
  1136. result := ctypeconvnode.create_internal(left,sinttype);
  1137. result := ctypeconvnode.create_internal(result,resulttype);
  1138. resulttypepass(result);
  1139. { left is reused }
  1140. left := nil;
  1141. end;
  1142. function ttypeconvnode.resulttype_enum_to_variant : tnode;
  1143. begin
  1144. result := ctypeconvnode.create_internal(left,sinttype);
  1145. result := ctypeconvnode.create_internal(result,cvarianttype);
  1146. resulttypepass(result);
  1147. { left is reused }
  1148. left := nil;
  1149. end;
  1150. function ttypeconvnode.resulttype_array_2_dynarray : tnode;
  1151. var
  1152. newstatement : tstatementnode;
  1153. temp : ttempcreatenode;
  1154. temp2 : ttempcreatenode;
  1155. begin
  1156. { create statements with call to getmem+initialize }
  1157. result:=internalstatements(newstatement);
  1158. { create temp for result }
  1159. temp:=ctempcreatenode.create(resulttype,resulttype.def.size,tt_persistent,true);
  1160. addstatement(newstatement,temp);
  1161. { get temp for array of lengths }
  1162. temp2:=ctempcreatenode.create(sinttype,sinttype.def.size,tt_persistent,false);
  1163. addstatement(newstatement,temp2);
  1164. { one dimensional }
  1165. addstatement(newstatement,cassignmentnode.create(
  1166. ctemprefnode.create_offset(temp2,0),
  1167. cordconstnode.create
  1168. (tarraydef(left.resulttype.def).highrange+1,s32inttype,true)));
  1169. { create call to fpc_dynarr_setlength }
  1170. addstatement(newstatement,ccallnode.createintern('fpc_dynarray_setlength',
  1171. ccallparanode.create(caddrnode.create_internal
  1172. (ctemprefnode.create(temp2)),
  1173. ccallparanode.create(cordconstnode.create
  1174. (1,s32inttype,true),
  1175. ccallparanode.create(caddrnode.create_internal
  1176. (crttinode.create(tstoreddef(resulttype.def),initrtti)),
  1177. ccallparanode.create(
  1178. ctypeconvnode.create_internal(
  1179. ctemprefnode.create(temp),voidpointertype),
  1180. nil))))
  1181. ));
  1182. addstatement(newstatement,ctempdeletenode.create(temp2));
  1183. { copy ... }
  1184. addstatement(newstatement,cassignmentnode.create(
  1185. ctypeconvnode.create_internal(cderefnode.create(ctypeconvnode.create_internal(ctemprefnode.create(temp),voidpointertype)),left.resulttype),
  1186. left
  1187. ));
  1188. { left is reused }
  1189. left:=nil;
  1190. { the last statement should return the value as
  1191. location and type, this is done be referencing the
  1192. temp and converting it first from a persistent temp to
  1193. normal temp }
  1194. addstatement(newstatement,ctempdeletenode.create_normal_temp(temp));
  1195. addstatement(newstatement,ctemprefnode.create(temp));
  1196. end;
  1197. procedure copyparasym(p:TNamedIndexItem;arg:pointer);
  1198. var
  1199. newparast : tsymtable absolute arg;
  1200. vs : tparavarsym;
  1201. begin
  1202. if tsym(p).typ<>paravarsym then
  1203. exit;
  1204. with tparavarsym(p) do
  1205. begin
  1206. vs:=tparavarsym.create(realname,paranr,varspez,vartype,varoptions);
  1207. vs.defaultconstsym:=defaultconstsym;
  1208. newparast.insert(vs);
  1209. end;
  1210. end;
  1211. function ttypeconvnode.resulttype_proc_to_procvar : tnode;
  1212. var
  1213. pd : tabstractprocdef;
  1214. begin
  1215. result:=nil;
  1216. pd:=tabstractprocdef(left.resulttype.def);
  1217. { create procvardef }
  1218. resulttype.setdef(tprocvardef.create(pd.parast.symtablelevel));
  1219. tprocvardef(resulttype.def).proctypeoption:=pd.proctypeoption;
  1220. tprocvardef(resulttype.def).proccalloption:=pd.proccalloption;
  1221. tprocvardef(resulttype.def).procoptions:=pd.procoptions;
  1222. tprocvardef(resulttype.def).rettype:=pd.rettype;
  1223. { method ? then set the methodpointer flag }
  1224. if (pd.owner.symtabletype=objectsymtable) then
  1225. include(tprocvardef(resulttype.def).procoptions,po_methodpointer);
  1226. { was it a local procedure? }
  1227. if (pd.owner.symtabletype=localsymtable) then
  1228. include(tprocvardef(resulttype.def).procoptions,po_local);
  1229. { only need the address of the method? this is needed
  1230. for @tobject.create. In this case there will be a loadn without
  1231. a methodpointer. }
  1232. if (left.nodetype=loadn) and
  1233. not assigned(tloadnode(left).left) then
  1234. include(tprocvardef(resulttype.def).procoptions,po_addressonly);
  1235. { Add parameters use only references, we don't need to keep the
  1236. parast. We use the parast from the original function to calculate
  1237. our parameter data and reset it afterwards }
  1238. pd.parast.foreach_static(@copyparasym,tprocvardef(resulttype.def).parast);
  1239. tprocvardef(resulttype.def).calcparas;
  1240. end;
  1241. function ttypeconvnode.resulttype_call_helper(c : tconverttype) : tnode;
  1242. const
  1243. resulttypeconvert : array[tconverttype] of pointer = (
  1244. {none} nil,
  1245. {equal} nil,
  1246. {not_possible} nil,
  1247. { string_2_string } @ttypeconvnode.resulttype_string_to_string,
  1248. { char_2_string } @ttypeconvnode.resulttype_char_to_string,
  1249. { char_2_chararray } @ttypeconvnode.resulttype_char_to_chararray,
  1250. { pchar_2_string } @ttypeconvnode.resulttype_pchar_to_string,
  1251. { cchar_2_pchar } @ttypeconvnode.resulttype_cchar_to_pchar,
  1252. { cstring_2_pchar } @ttypeconvnode.resulttype_cstring_to_pchar,
  1253. { cstring_2_int } @ttypeconvnode.resulttype_cstring_to_int,
  1254. { ansistring_2_pchar } nil,
  1255. { string_2_chararray } @ttypeconvnode.resulttype_string_to_chararray,
  1256. { chararray_2_string } @ttypeconvnode.resulttype_chararray_to_string,
  1257. { array_2_pointer } nil,
  1258. { pointer_2_array } nil,
  1259. { int_2_int } @ttypeconvnode.resulttype_int_to_int,
  1260. { int_2_bool } nil,
  1261. { int_2_string } @ttypeconvnode.resulttype_int_to_string,
  1262. { bool_2_bool } nil,
  1263. { bool_2_int } nil,
  1264. { real_2_real } @ttypeconvnode.resulttype_real_to_real,
  1265. { int_2_real } @ttypeconvnode.resulttype_int_to_real,
  1266. { real_2_currency } @ttypeconvnode.resulttype_real_to_currency,
  1267. { proc_2_procvar } @ttypeconvnode.resulttype_proc_to_procvar,
  1268. { arrayconstructor_2_set } @ttypeconvnode.resulttype_arrayconstructor_to_set,
  1269. { load_smallset } nil,
  1270. { cord_2_pointer } @ttypeconvnode.resulttype_cord_to_pointer,
  1271. { intf_2_string } nil,
  1272. { intf_2_guid } @ttypeconvnode.resulttype_interface_to_guid,
  1273. { class_2_intf } nil,
  1274. { char_2_char } @ttypeconvnode.resulttype_char_to_char,
  1275. { normal_2_smallset} nil,
  1276. { dynarray_2_openarray} @ttypeconvnode.resulttype_dynarray_to_openarray,
  1277. { pwchar_2_string} @ttypeconvnode.resulttype_pwchar_to_string,
  1278. { variant_2_dynarray} @ttypeconvnode.resulttype_variant_to_dynarray,
  1279. { dynarray_2_variant} @ttypeconvnode.resulttype_dynarray_to_variant,
  1280. { variant_2_enum} @ttypeconvnode.resulttype_variant_to_enum,
  1281. { enum_2_variant} @ttypeconvnode.resulttype_enum_to_variant,
  1282. { variant_2_interface} @ttypeconvnode.resulttype_interface_to_variant,
  1283. { interface_2_variant} @ttypeconvnode.resulttype_variant_to_interface,
  1284. { array_2_dynarray} @ttypeconvnode.resulttype_array_2_dynarray
  1285. );
  1286. type
  1287. tprocedureofobject = function : tnode of object;
  1288. var
  1289. r : packed record
  1290. proc : pointer;
  1291. obj : pointer;
  1292. end;
  1293. begin
  1294. result:=nil;
  1295. { this is a little bit dirty but it works }
  1296. { and should be quite portable too }
  1297. r.proc:=resulttypeconvert[c];
  1298. r.obj:=self;
  1299. if assigned(r.proc) then
  1300. result:=tprocedureofobject(r)();
  1301. end;
  1302. function ttypeconvnode.det_resulttype:tnode;
  1303. var
  1304. htype : ttype;
  1305. hp : tnode;
  1306. currprocdef : tabstractprocdef;
  1307. aprocdef : tprocdef;
  1308. eq : tequaltype;
  1309. cdoptions : tcompare_defs_options;
  1310. begin
  1311. result:=nil;
  1312. resulttype:=totype;
  1313. resulttypepass(left);
  1314. if codegenerror then
  1315. exit;
  1316. { When absolute force tc_equal }
  1317. if (nf_absolute in flags) then
  1318. begin
  1319. convtype:=tc_equal;
  1320. if not(tstoreddef(resulttype.def).is_intregable) and
  1321. not(tstoreddef(resulttype.def).is_fpuregable) then
  1322. make_not_regable(left,vr_addr);
  1323. exit;
  1324. end;
  1325. { tp procvar support. Skip typecasts to procvar, record or set. Those
  1326. convert on the procvar value. This is used to access the
  1327. fields of a methodpointer }
  1328. if not(nf_load_procvar in flags) and
  1329. not(resulttype.def.deftype in [procvardef,recorddef,setdef]) then
  1330. maybe_call_procvar(left,true);
  1331. { convert array constructors to sets, because there is no conversion
  1332. possible for array constructors }
  1333. if (resulttype.def.deftype<>arraydef) and
  1334. is_array_constructor(left.resulttype.def) then
  1335. begin
  1336. arrayconstructor_to_set(left);
  1337. resulttypepass(left);
  1338. end;
  1339. if convtype=tc_none then
  1340. begin
  1341. cdoptions:=[cdo_check_operator,cdo_allow_variant];
  1342. if nf_explicit in flags then
  1343. include(cdoptions,cdo_explicit);
  1344. if nf_internal in flags then
  1345. include(cdoptions,cdo_internal);
  1346. eq:=compare_defs_ext(left.resulttype.def,resulttype.def,left.nodetype,convtype,aprocdef,cdoptions);
  1347. case eq of
  1348. te_exact,
  1349. te_equal :
  1350. begin
  1351. result := simplify;
  1352. if assigned(result) then
  1353. exit;
  1354. { because is_equal only checks the basetype for sets we need to
  1355. check here if we are loading a smallset into a normalset }
  1356. if (resulttype.def.deftype=setdef) and
  1357. (left.resulttype.def.deftype=setdef) and
  1358. ((tsetdef(resulttype.def).settype = smallset) xor
  1359. (tsetdef(left.resulttype.def).settype = smallset)) then
  1360. begin
  1361. { constant sets can be converted by changing the type only }
  1362. if (left.nodetype=setconstn) then
  1363. begin
  1364. left.resulttype:=resulttype;
  1365. result:=left;
  1366. left:=nil;
  1367. exit;
  1368. end;
  1369. if (tsetdef(resulttype.def).settype <> smallset) then
  1370. convtype:=tc_load_smallset
  1371. else
  1372. convtype := tc_normal_2_smallset;
  1373. exit;
  1374. end
  1375. else
  1376. begin
  1377. { Only leave when there is no conversion to do.
  1378. We can still need to call a conversion routine,
  1379. like the routine to convert a stringconstnode }
  1380. if convtype in [tc_equal,tc_not_possible] then
  1381. begin
  1382. left.resulttype:=resulttype;
  1383. if (nf_explicit in flags) and (left.nodetype = addrn) then
  1384. include(left.flags, nf_typedaddr);
  1385. result:=left;
  1386. left:=nil;
  1387. exit;
  1388. end;
  1389. end;
  1390. end;
  1391. te_convert_l1,
  1392. te_convert_l2,
  1393. te_convert_l3 :
  1394. begin
  1395. result := simplify;
  1396. if assigned(result) then
  1397. exit;
  1398. { nothing to do }
  1399. end;
  1400. te_convert_operator :
  1401. begin
  1402. include(current_procinfo.flags,pi_do_call);
  1403. inc(aprocdef.procsym.refs);
  1404. hp:=ccallnode.create(ccallparanode.create(left,nil),Tprocsym(aprocdef.procsym),nil,nil,[]);
  1405. { tell explicitly which def we must use !! (PM) }
  1406. tcallnode(hp).procdefinition:=aprocdef;
  1407. left:=nil;
  1408. result:=hp;
  1409. exit;
  1410. end;
  1411. te_incompatible :
  1412. begin
  1413. { Procedures have a resulttype.def of voiddef and functions of their
  1414. own resulttype.def. They will therefore always be incompatible with
  1415. a procvar. Because isconvertable cannot check for procedures we
  1416. use an extra check for them.}
  1417. if (left.nodetype=calln) and
  1418. (tcallnode(left).para_count=0) and
  1419. (resulttype.def.deftype=procvardef) and
  1420. (
  1421. (m_tp_procvar in aktmodeswitches) or
  1422. (m_mac_procvar in aktmodeswitches)
  1423. ) then
  1424. begin
  1425. if assigned(tcallnode(left).right) then
  1426. begin
  1427. { this is already a procvar, if it is really equal
  1428. is checked below }
  1429. convtype:=tc_equal;
  1430. hp:=tcallnode(left).right.getcopy;
  1431. currprocdef:=tabstractprocdef(hp.resulttype.def);
  1432. end
  1433. else
  1434. begin
  1435. convtype:=tc_proc_2_procvar;
  1436. currprocdef:=Tprocsym(Tcallnode(left).symtableprocentry).search_procdef_byprocvardef(Tprocvardef(resulttype.def));
  1437. hp:=cloadnode.create_procvar(tprocsym(tcallnode(left).symtableprocentry),
  1438. tprocdef(currprocdef),tcallnode(left).symtableproc);
  1439. if (tcallnode(left).symtableprocentry.owner.symtabletype=objectsymtable) then
  1440. begin
  1441. if assigned(tcallnode(left).methodpointer) then
  1442. tloadnode(hp).set_mp(tcallnode(left).get_load_methodpointer)
  1443. else
  1444. tloadnode(hp).set_mp(load_self_node);
  1445. end;
  1446. resulttypepass(hp);
  1447. end;
  1448. left.free;
  1449. left:=hp;
  1450. { Now check if the procedure we are going to assign to
  1451. the procvar, is compatible with the procvar's type }
  1452. if not(nf_explicit in flags) and
  1453. (proc_to_procvar_equal(currprocdef,tprocvardef(resulttype.def))=te_incompatible) then
  1454. IncompatibleTypes(left.resulttype.def,resulttype.def);
  1455. exit;
  1456. end;
  1457. { Handle explicit type conversions }
  1458. if nf_explicit in flags then
  1459. begin
  1460. { do common tc_equal cast }
  1461. convtype:=tc_equal;
  1462. { ordinal constants can be resized to 1,2,4,8 bytes }
  1463. if (left.nodetype=ordconstn) then
  1464. begin
  1465. { Insert typeconv for ordinal to the correct size first on left, after
  1466. that the other conversion can be done }
  1467. htype.reset;
  1468. case longint(resulttype.def.size) of
  1469. 1 :
  1470. htype:=s8inttype;
  1471. 2 :
  1472. htype:=s16inttype;
  1473. 4 :
  1474. htype:=s32inttype;
  1475. 8 :
  1476. htype:=s64inttype;
  1477. end;
  1478. { we need explicit, because it can also be an enum }
  1479. if assigned(htype.def) then
  1480. inserttypeconv_internal(left,htype)
  1481. else
  1482. CGMessage2(type_e_illegal_type_conversion,left.resulttype.def.gettypename,resulttype.def.gettypename);
  1483. end;
  1484. { check if the result could be in a register }
  1485. if (not(tstoreddef(resulttype.def).is_intregable) and
  1486. not(tstoreddef(resulttype.def).is_fpuregable)) or
  1487. ((left.resulttype.def.deftype = floatdef) and
  1488. (resulttype.def.deftype <> floatdef)) then
  1489. make_not_regable(left,vr_addr);
  1490. { class/interface to class/interface, with checkobject support }
  1491. if is_class_or_interface(resulttype.def) and
  1492. is_class_or_interface(left.resulttype.def) then
  1493. begin
  1494. { check if the types are related }
  1495. if not(nf_internal in flags) and
  1496. (not(tobjectdef(left.resulttype.def).is_related(tobjectdef(resulttype.def)))) and
  1497. (not(tobjectdef(resulttype.def).is_related(tobjectdef(left.resulttype.def)))) then
  1498. begin
  1499. { Give an error when typecasting class to interface, this is compatible
  1500. with delphi }
  1501. if is_interface(resulttype.def) and
  1502. not is_interface(left.resulttype.def) then
  1503. CGMessage2(type_e_classes_not_related,
  1504. FullTypeName(left.resulttype.def,resulttype.def),
  1505. FullTypeName(resulttype.def,left.resulttype.def))
  1506. else
  1507. CGMessage2(type_w_classes_not_related,
  1508. FullTypeName(left.resulttype.def,resulttype.def),
  1509. FullTypeName(resulttype.def,left.resulttype.def))
  1510. end;
  1511. { Add runtime check? }
  1512. if (cs_check_object in aktlocalswitches) then
  1513. begin
  1514. { we can translate the typeconvnode to 'as' when
  1515. typecasting to a class or interface }
  1516. hp:=casnode.create(left,cloadvmtaddrnode.create(ctypenode.create(resulttype)));
  1517. left:=nil;
  1518. result:=hp;
  1519. exit;
  1520. end;
  1521. end
  1522. else
  1523. begin
  1524. { only if the same size or formal def }
  1525. if not(
  1526. (left.resulttype.def.deftype=formaldef) or
  1527. (
  1528. not(is_open_array(left.resulttype.def)) and
  1529. not(is_array_constructor(left.resulttype.def)) and
  1530. (left.resulttype.def.size=resulttype.def.size)
  1531. ) or
  1532. (
  1533. is_void(left.resulttype.def) and
  1534. (left.nodetype=derefn)
  1535. )
  1536. ) then
  1537. CGMessage2(type_e_illegal_type_conversion,left.resulttype.def.gettypename,resulttype.def.gettypename);
  1538. end;
  1539. end
  1540. else
  1541. IncompatibleTypes(left.resulttype.def,resulttype.def);
  1542. end;
  1543. else
  1544. internalerror(200211231);
  1545. end;
  1546. end;
  1547. { Give hint or warning for unportable code, exceptions are
  1548. - typecasts from constants
  1549. - void }
  1550. if not(nf_internal in flags) and
  1551. (left.nodetype<>ordconstn) and
  1552. not(is_void(left.resulttype.def)) and
  1553. (((left.resulttype.def.deftype=orddef) and
  1554. (resulttype.def.deftype in [pointerdef,procvardef,classrefdef])) or
  1555. ((resulttype.def.deftype=orddef) and
  1556. (left.resulttype.def.deftype in [pointerdef,procvardef,classrefdef]))) then
  1557. begin
  1558. { Give a warning when sizes don't match, because then info will be lost }
  1559. if left.resulttype.def.size=resulttype.def.size then
  1560. CGMessage(type_h_pointer_to_longint_conv_not_portable)
  1561. else
  1562. CGMessage(type_w_pointer_to_longint_conv_not_portable);
  1563. end;
  1564. result := simplify;
  1565. if assigned(result) then
  1566. exit;
  1567. { now call the resulttype helper to do constant folding }
  1568. result:=resulttype_call_helper(convtype);
  1569. end;
  1570. function ttypeconvnode.simplify: tnode;
  1571. var
  1572. hp: tnode;
  1573. begin
  1574. result := nil;
  1575. { Constant folding and other node transitions to
  1576. remove the typeconv node }
  1577. case left.nodetype of
  1578. realconstn :
  1579. begin
  1580. if (convtype = tc_real_2_currency) then
  1581. result := resulttype_real_to_currency
  1582. else if (convtype = tc_real_2_real) then
  1583. result := resulttype_real_to_real
  1584. else
  1585. exit;
  1586. if not(assigned(result)) then
  1587. begin
  1588. result := left;
  1589. left := nil;
  1590. end;
  1591. if (result.nodetype = realconstn) then
  1592. begin
  1593. result:=crealconstnode.create(trealconstnode(result).value_real,resulttype);
  1594. if ([nf_explicit,nf_internal] * flags <> []) then
  1595. include(result.flags, nf_explicit);
  1596. end;
  1597. end;
  1598. niln :
  1599. begin
  1600. { nil to ordinal node }
  1601. if (resulttype.def.deftype=orddef) then
  1602. begin
  1603. hp:=cordconstnode.create(0,resulttype,true);
  1604. if ([nf_explicit,nf_internal] * flags <> []) then
  1605. include(hp.flags, nf_explicit);
  1606. result:=hp;
  1607. exit;
  1608. end
  1609. else
  1610. { fold nil to any pointer type }
  1611. if (resulttype.def.deftype=pointerdef) then
  1612. begin
  1613. hp:=cnilnode.create;
  1614. hp.resulttype:=resulttype;
  1615. if ([nf_explicit,nf_internal] * flags <> []) then
  1616. include(hp.flags, nf_explicit);
  1617. result:=hp;
  1618. exit;
  1619. end
  1620. else
  1621. { remove typeconv after niln, but not when the result is a
  1622. methodpointer. The typeconv of the methodpointer will then
  1623. take care of updateing size of niln to OS_64 }
  1624. if not((resulttype.def.deftype=procvardef) and
  1625. (po_methodpointer in tprocvardef(resulttype.def).procoptions)) then
  1626. begin
  1627. left.resulttype:=resulttype;
  1628. if ([nf_explicit,nf_internal] * flags <> []) then
  1629. include(left.flags, nf_explicit);
  1630. result:=left;
  1631. left:=nil;
  1632. exit;
  1633. end;
  1634. end;
  1635. ordconstn :
  1636. begin
  1637. { ordinal contants can be directly converted }
  1638. { but not char to char because it is a widechar to char or via versa }
  1639. { which needs extra code to do the code page transistion }
  1640. { constant ordinal to pointer }
  1641. if (resulttype.def.deftype=pointerdef) and
  1642. (convtype<>tc_cchar_2_pchar) then
  1643. begin
  1644. hp:=cpointerconstnode.create(TConstPtrUInt(tordconstnode(left).value),resulttype);
  1645. if ([nf_explicit,nf_internal] * flags <> []) then
  1646. include(hp.flags, nf_explicit);
  1647. result:=hp;
  1648. exit;
  1649. end
  1650. else if is_ordinal(resulttype.def) and
  1651. not(convtype=tc_char_2_char) then
  1652. begin
  1653. { replace the resulttype and recheck the range }
  1654. left.resulttype:=resulttype;
  1655. if ([nf_explicit,nf_internal] * flags <> []) then
  1656. include(left.flags, nf_explicit);
  1657. testrange(left.resulttype.def,tordconstnode(left).value,(nf_explicit in flags));
  1658. result:=left;
  1659. left:=nil;
  1660. exit;
  1661. end;
  1662. end;
  1663. pointerconstn :
  1664. begin
  1665. { pointerconstn to any pointer is folded too }
  1666. if (resulttype.def.deftype=pointerdef) then
  1667. begin
  1668. left.resulttype:=resulttype;
  1669. if ([nf_explicit,nf_internal] * flags <> []) then
  1670. include(left.flags, nf_explicit);
  1671. result:=left;
  1672. left:=nil;
  1673. exit;
  1674. end
  1675. { constant pointer to ordinal }
  1676. else if is_ordinal(resulttype.def) then
  1677. begin
  1678. hp:=cordconstnode.create(TConstExprInt(tpointerconstnode(left).value),
  1679. resulttype,not(nf_explicit in flags));
  1680. if ([nf_explicit,nf_internal] * flags <> []) then
  1681. include(hp.flags, nf_explicit);
  1682. result:=hp;
  1683. exit;
  1684. end;
  1685. end;
  1686. end;
  1687. end;
  1688. procedure Ttypeconvnode.mark_write;
  1689. begin
  1690. left.mark_write;
  1691. end;
  1692. function ttypeconvnode.first_cord_to_pointer : tnode;
  1693. begin
  1694. result:=nil;
  1695. internalerror(200104043);
  1696. end;
  1697. function ttypeconvnode.first_int_to_int : tnode;
  1698. begin
  1699. first_int_to_int:=nil;
  1700. expectloc:=left.expectloc;
  1701. if not is_void(left.resulttype.def) then
  1702. begin
  1703. if (left.expectloc<>LOC_REGISTER) and
  1704. (resulttype.def.size>left.resulttype.def.size) then
  1705. expectloc:=LOC_REGISTER
  1706. else
  1707. if (left.expectloc=LOC_CREGISTER) and
  1708. (resulttype.def.size<left.resulttype.def.size) then
  1709. expectloc:=LOC_REGISTER;
  1710. end;
  1711. {$ifndef cpu64bit}
  1712. if is_64bit(resulttype.def) then
  1713. registersint:=max(registersint,2)
  1714. else
  1715. {$endif cpu64bit}
  1716. registersint:=max(registersint,1);
  1717. end;
  1718. function ttypeconvnode.first_cstring_to_pchar : tnode;
  1719. begin
  1720. result:=nil;
  1721. registersint:=1;
  1722. expectloc:=LOC_REGISTER;
  1723. end;
  1724. function ttypeconvnode.first_cstring_to_int : tnode;
  1725. begin
  1726. result:=nil;
  1727. internalerror(200510014);
  1728. end;
  1729. function ttypeconvnode.first_string_to_chararray : tnode;
  1730. begin
  1731. first_string_to_chararray:=nil;
  1732. expectloc:=left.expectloc;
  1733. end;
  1734. function ttypeconvnode.first_char_to_string : tnode;
  1735. begin
  1736. first_char_to_string:=nil;
  1737. expectloc:=LOC_REFERENCE;
  1738. end;
  1739. function ttypeconvnode.first_nothing : tnode;
  1740. begin
  1741. first_nothing:=nil;
  1742. end;
  1743. function ttypeconvnode.first_array_to_pointer : tnode;
  1744. begin
  1745. first_array_to_pointer:=nil;
  1746. if registersint<1 then
  1747. registersint:=1;
  1748. expectloc:=LOC_REGISTER;
  1749. end;
  1750. function ttypeconvnode.first_int_to_real: tnode;
  1751. var
  1752. fname: string[32];
  1753. typname : string[12];
  1754. begin
  1755. { Get the type name }
  1756. { Normally the typename should be one of the following:
  1757. single, double - carl
  1758. }
  1759. typname := lower(pbestrealtype^.def.gettypename);
  1760. { converting a 64bit integer to a float requires a helper }
  1761. if is_64bit(left.resulttype.def) then
  1762. begin
  1763. if is_signed(left.resulttype.def) then
  1764. fname := 'fpc_int64_to_'+typname
  1765. else
  1766. {$warning generic conversion from int to float does not support unsigned integers}
  1767. fname := 'fpc_int64_to_'+typname;
  1768. result := ccallnode.createintern(fname,ccallparanode.create(
  1769. left,nil));
  1770. left:=nil;
  1771. firstpass(result);
  1772. exit;
  1773. end
  1774. else
  1775. { other integers are supposed to be 32 bit }
  1776. begin
  1777. {$warning generic conversion from int to float does not support unsigned integers}
  1778. if is_signed(left.resulttype.def) then
  1779. fname := 'fpc_longint_to_'+typname
  1780. else
  1781. fname := 'fpc_longint_to_'+typname;
  1782. result := ccallnode.createintern(fname,ccallparanode.create(
  1783. left,nil));
  1784. left:=nil;
  1785. firstpass(result);
  1786. exit;
  1787. end;
  1788. end;
  1789. function ttypeconvnode.first_real_to_real : tnode;
  1790. begin
  1791. {$ifdef cpufpemu}
  1792. if cs_fp_emulation in aktmoduleswitches then
  1793. begin
  1794. if target_info.system in system_wince then
  1795. begin
  1796. case tfloatdef(left.resulttype.def).typ of
  1797. s32real:
  1798. case tfloatdef(resulttype.def).typ of
  1799. s64real:
  1800. result:=ccallnode.createintern('STOD',ccallparanode.create(left,nil));
  1801. s32real:
  1802. begin
  1803. result:=left;
  1804. left:=nil;
  1805. end;
  1806. else
  1807. internalerror(2005082704);
  1808. end;
  1809. s64real:
  1810. case tfloatdef(resulttype.def).typ of
  1811. s32real:
  1812. result:=ccallnode.createintern('DTOS',ccallparanode.create(left,nil));
  1813. s64real:
  1814. begin
  1815. result:=left;
  1816. left:=nil;
  1817. end;
  1818. else
  1819. internalerror(2005082703);
  1820. end;
  1821. else
  1822. internalerror(2005082702);
  1823. end;
  1824. left:=nil;
  1825. firstpass(result);
  1826. exit;
  1827. end
  1828. else
  1829. begin
  1830. case tfloatdef(left.resulttype.def).typ of
  1831. s32real:
  1832. case tfloatdef(resulttype.def).typ of
  1833. s64real:
  1834. result:=ctypeconvnode.create_explicit(ccallnode.createintern('float32_to_float64',ccallparanode.create(
  1835. ctypeconvnode.create_internal(left,search_system_type('FLOAT32REC').restype),nil)),resulttype);
  1836. s32real:
  1837. begin
  1838. result:=left;
  1839. left:=nil;
  1840. end;
  1841. else
  1842. internalerror(200610151);
  1843. end;
  1844. s64real:
  1845. case tfloatdef(resulttype.def).typ of
  1846. s32real:
  1847. result:=ctypeconvnode.create_explicit(ccallnode.createintern('float64_to_float32',ccallparanode.create(
  1848. ctypeconvnode.create_internal(left,search_system_type('FLOAT64').restype),nil)),resulttype);
  1849. s64real:
  1850. begin
  1851. result:=left;
  1852. left:=nil;
  1853. end;
  1854. else
  1855. internalerror(200610152);
  1856. end;
  1857. else
  1858. internalerror(200610153);
  1859. end;
  1860. left:=nil;
  1861. firstpass(result);
  1862. exit;
  1863. end;
  1864. end
  1865. else
  1866. {$endif cpufpemu}
  1867. begin
  1868. first_real_to_real:=nil;
  1869. if registersfpu<1 then
  1870. registersfpu:=1;
  1871. expectloc:=LOC_FPUREGISTER;
  1872. end;
  1873. end;
  1874. function ttypeconvnode.first_pointer_to_array : tnode;
  1875. begin
  1876. first_pointer_to_array:=nil;
  1877. if registersint<1 then
  1878. registersint:=1;
  1879. expectloc:=LOC_REFERENCE;
  1880. end;
  1881. function ttypeconvnode.first_cchar_to_pchar : tnode;
  1882. begin
  1883. first_cchar_to_pchar:=nil;
  1884. internalerror(200104021);
  1885. end;
  1886. function ttypeconvnode.first_bool_to_int : tnode;
  1887. begin
  1888. first_bool_to_int:=nil;
  1889. { byte(boolean) or word(wordbool) or longint(longbool) must
  1890. be accepted for var parameters }
  1891. if (nf_explicit in flags) and
  1892. (left.resulttype.def.size=resulttype.def.size) and
  1893. (left.expectloc in [LOC_REFERENCE,LOC_CREFERENCE,LOC_CREGISTER]) then
  1894. exit;
  1895. { when converting to 64bit, first convert to a 32bit int and then }
  1896. { convert to a 64bit int (only necessary for 32bit processors) (JM) }
  1897. if resulttype.def.size > sizeof(aint) then
  1898. begin
  1899. result := ctypeconvnode.create_internal(left,u32inttype);
  1900. result := ctypeconvnode.create(result,resulttype);
  1901. left := nil;
  1902. firstpass(result);
  1903. exit;
  1904. end;
  1905. expectloc:=LOC_REGISTER;
  1906. if registersint<1 then
  1907. registersint:=1;
  1908. end;
  1909. function ttypeconvnode.first_int_to_bool : tnode;
  1910. begin
  1911. first_int_to_bool:=nil;
  1912. { byte(boolean) or word(wordbool) or longint(longbool) must
  1913. be accepted for var parameters }
  1914. if (nf_explicit in flags) and
  1915. (left.resulttype.def.size=resulttype.def.size) and
  1916. (left.expectloc in [LOC_REFERENCE,LOC_CREFERENCE,LOC_CREGISTER]) then
  1917. exit;
  1918. expectloc:=LOC_REGISTER;
  1919. { need if bool to bool !!
  1920. not very nice !!
  1921. insertypeconv(left,s32inttype);
  1922. left.explizit:=true;
  1923. firstpass(left); }
  1924. if registersint<1 then
  1925. registersint:=1;
  1926. end;
  1927. function ttypeconvnode.first_bool_to_bool : tnode;
  1928. begin
  1929. first_bool_to_bool:=nil;
  1930. if (left.expectloc in [LOC_FLAGS,LOC_JUMP]) then
  1931. expectloc := left.expectloc
  1932. else
  1933. begin
  1934. expectloc:=LOC_REGISTER;
  1935. if registersint<1 then
  1936. registersint:=1;
  1937. end;
  1938. end;
  1939. function ttypeconvnode.first_char_to_char : tnode;
  1940. begin
  1941. first_char_to_char:=first_int_to_int;
  1942. end;
  1943. function ttypeconvnode.first_proc_to_procvar : tnode;
  1944. begin
  1945. first_proc_to_procvar:=nil;
  1946. if tabstractprocdef(resulttype.def).is_addressonly then
  1947. begin
  1948. registersint:=left.registersint;
  1949. if registersint<1 then
  1950. registersint:=1;
  1951. expectloc:=LOC_REGISTER;
  1952. end
  1953. else
  1954. begin
  1955. if not(left.expectloc in [LOC_CREFERENCE,LOC_REFERENCE]) then
  1956. CGMessage(parser_e_illegal_expression);
  1957. registersint:=left.registersint;
  1958. expectloc:=left.expectloc
  1959. end
  1960. end;
  1961. function ttypeconvnode.first_load_smallset : tnode;
  1962. var
  1963. srsym: ttypesym;
  1964. p: tcallparanode;
  1965. begin
  1966. srsym:=search_system_type('FPC_SMALL_SET');
  1967. p := ccallparanode.create(left,nil);
  1968. { reused }
  1969. left := nil;
  1970. { convert parameter explicitely to fpc_small_set }
  1971. p.left := ctypeconvnode.create_internal(p.left,srsym.restype);
  1972. { create call, adjust resulttype }
  1973. result :=
  1974. ccallnode.createinternres('fpc_set_load_small',p,resulttype);
  1975. firstpass(result);
  1976. end;
  1977. function ttypeconvnode.first_ansistring_to_pchar : tnode;
  1978. begin
  1979. first_ansistring_to_pchar:=nil;
  1980. expectloc:=LOC_REGISTER;
  1981. if registersint<1 then
  1982. registersint:=1;
  1983. end;
  1984. function ttypeconvnode.first_arrayconstructor_to_set : tnode;
  1985. begin
  1986. first_arrayconstructor_to_set:=nil;
  1987. internalerror(200104022);
  1988. end;
  1989. function ttypeconvnode.first_class_to_intf : tnode;
  1990. begin
  1991. first_class_to_intf:=nil;
  1992. expectloc:=LOC_REGISTER;
  1993. if registersint<1 then
  1994. registersint:=1;
  1995. end;
  1996. function ttypeconvnode._first_int_to_int : tnode;
  1997. begin
  1998. result:=first_int_to_int;
  1999. end;
  2000. function ttypeconvnode._first_cstring_to_pchar : tnode;
  2001. begin
  2002. result:=first_cstring_to_pchar;
  2003. end;
  2004. function ttypeconvnode._first_cstring_to_int : tnode;
  2005. begin
  2006. result:=first_cstring_to_int;
  2007. end;
  2008. function ttypeconvnode._first_string_to_chararray : tnode;
  2009. begin
  2010. result:=first_string_to_chararray;
  2011. end;
  2012. function ttypeconvnode._first_char_to_string : tnode;
  2013. begin
  2014. result:=first_char_to_string;
  2015. end;
  2016. function ttypeconvnode._first_nothing : tnode;
  2017. begin
  2018. result:=first_nothing;
  2019. end;
  2020. function ttypeconvnode._first_array_to_pointer : tnode;
  2021. begin
  2022. result:=first_array_to_pointer;
  2023. end;
  2024. function ttypeconvnode._first_int_to_real : tnode;
  2025. begin
  2026. result:=first_int_to_real;
  2027. end;
  2028. function ttypeconvnode._first_real_to_real : tnode;
  2029. begin
  2030. result:=first_real_to_real;
  2031. end;
  2032. function ttypeconvnode._first_pointer_to_array : tnode;
  2033. begin
  2034. result:=first_pointer_to_array;
  2035. end;
  2036. function ttypeconvnode._first_cchar_to_pchar : tnode;
  2037. begin
  2038. result:=first_cchar_to_pchar;
  2039. end;
  2040. function ttypeconvnode._first_bool_to_int : tnode;
  2041. begin
  2042. result:=first_bool_to_int;
  2043. end;
  2044. function ttypeconvnode._first_int_to_bool : tnode;
  2045. begin
  2046. result:=first_int_to_bool;
  2047. end;
  2048. function ttypeconvnode._first_bool_to_bool : tnode;
  2049. begin
  2050. result:=first_bool_to_bool;
  2051. end;
  2052. function ttypeconvnode._first_proc_to_procvar : tnode;
  2053. begin
  2054. result:=first_proc_to_procvar;
  2055. end;
  2056. function ttypeconvnode._first_load_smallset : tnode;
  2057. begin
  2058. result:=first_load_smallset;
  2059. end;
  2060. function ttypeconvnode._first_cord_to_pointer : tnode;
  2061. begin
  2062. result:=first_cord_to_pointer;
  2063. end;
  2064. function ttypeconvnode._first_ansistring_to_pchar : tnode;
  2065. begin
  2066. result:=first_ansistring_to_pchar;
  2067. end;
  2068. function ttypeconvnode._first_arrayconstructor_to_set : tnode;
  2069. begin
  2070. result:=first_arrayconstructor_to_set;
  2071. end;
  2072. function ttypeconvnode._first_class_to_intf : tnode;
  2073. begin
  2074. result:=first_class_to_intf;
  2075. end;
  2076. function ttypeconvnode._first_char_to_char : tnode;
  2077. begin
  2078. result:=first_char_to_char;
  2079. end;
  2080. function ttypeconvnode.first_call_helper(c : tconverttype) : tnode;
  2081. const
  2082. firstconvert : array[tconverttype] of pointer = (
  2083. nil, { none }
  2084. @ttypeconvnode._first_nothing, {equal}
  2085. @ttypeconvnode._first_nothing, {not_possible}
  2086. nil, { removed in resulttype_string_to_string }
  2087. @ttypeconvnode._first_char_to_string,
  2088. @ttypeconvnode._first_nothing, { char_2_chararray, needs nothing extra }
  2089. nil, { removed in resulttype_chararray_to_string }
  2090. @ttypeconvnode._first_cchar_to_pchar,
  2091. @ttypeconvnode._first_cstring_to_pchar,
  2092. @ttypeconvnode._first_cstring_to_int,
  2093. @ttypeconvnode._first_ansistring_to_pchar,
  2094. @ttypeconvnode._first_string_to_chararray,
  2095. nil, { removed in resulttype_chararray_to_string }
  2096. @ttypeconvnode._first_array_to_pointer,
  2097. @ttypeconvnode._first_pointer_to_array,
  2098. @ttypeconvnode._first_int_to_int,
  2099. @ttypeconvnode._first_int_to_bool,
  2100. nil, { removed in resulttype_int_to_string }
  2101. @ttypeconvnode._first_bool_to_bool,
  2102. @ttypeconvnode._first_bool_to_int,
  2103. @ttypeconvnode._first_real_to_real,
  2104. @ttypeconvnode._first_int_to_real,
  2105. nil, { removed in resulttype_real_to_currency }
  2106. @ttypeconvnode._first_proc_to_procvar,
  2107. @ttypeconvnode._first_arrayconstructor_to_set,
  2108. @ttypeconvnode._first_load_smallset,
  2109. @ttypeconvnode._first_cord_to_pointer,
  2110. @ttypeconvnode._first_nothing,
  2111. @ttypeconvnode._first_nothing,
  2112. @ttypeconvnode._first_class_to_intf,
  2113. @ttypeconvnode._first_char_to_char,
  2114. @ttypeconvnode._first_nothing,
  2115. @ttypeconvnode._first_nothing,
  2116. nil,
  2117. nil,
  2118. nil,
  2119. nil,
  2120. nil,
  2121. nil,
  2122. nil,
  2123. nil
  2124. );
  2125. type
  2126. tprocedureofobject = function : tnode of object;
  2127. var
  2128. r : packed record
  2129. proc : pointer;
  2130. obj : pointer;
  2131. end;
  2132. begin
  2133. { this is a little bit dirty but it works }
  2134. { and should be quite portable too }
  2135. r.proc:=firstconvert[c];
  2136. r.obj:=self;
  2137. if not assigned(r.proc) then
  2138. internalerror(200312081);
  2139. first_call_helper:=tprocedureofobject(r)()
  2140. end;
  2141. function ttypeconvnode.pass_1 : tnode;
  2142. begin
  2143. result:=nil;
  2144. firstpass(left);
  2145. if codegenerror then
  2146. exit;
  2147. { load the value_str from the left part }
  2148. registersint:=left.registersint;
  2149. registersfpu:=left.registersfpu;
  2150. {$ifdef SUPPORT_MMX}
  2151. registersmmx:=left.registersmmx;
  2152. {$endif}
  2153. expectloc:=left.expectloc;
  2154. result:=first_call_helper(convtype);
  2155. end;
  2156. function ttypeconvnode.assign_allowed:boolean;
  2157. begin
  2158. result:=(convtype=tc_equal) or
  2159. { typecasting from void is always allowed }
  2160. is_void(left.resulttype.def) or
  2161. (left.resulttype.def.deftype=formaldef) or
  2162. { int 2 int with same size reuses same location, or for
  2163. tp7 mode also allow size < orignal size }
  2164. (
  2165. (convtype=tc_int_2_int) and
  2166. (
  2167. (resulttype.def.size=left.resulttype.def.size) or
  2168. ((m_tp7 in aktmodeswitches) and
  2169. (resulttype.def.size<left.resulttype.def.size))
  2170. )
  2171. ) or
  2172. { int 2 bool/bool 2 int, explicit typecast, see also nx86cnv }
  2173. ((convtype in [tc_int_2_bool,tc_bool_2_int]) and
  2174. (nf_explicit in flags) and
  2175. (resulttype.def.size=left.resulttype.def.size));
  2176. { When using only a part of the value it can't be in a register since
  2177. that will load the value in a new register first }
  2178. if (resulttype.def.size<left.resulttype.def.size) then
  2179. make_not_regable(left,vr_addr);
  2180. end;
  2181. function ttypeconvnode.docompare(p: tnode) : boolean;
  2182. begin
  2183. docompare :=
  2184. inherited docompare(p) and
  2185. (convtype = ttypeconvnode(p).convtype);
  2186. end;
  2187. procedure ttypeconvnode._second_int_to_int;
  2188. begin
  2189. second_int_to_int;
  2190. end;
  2191. procedure ttypeconvnode._second_string_to_string;
  2192. begin
  2193. second_string_to_string;
  2194. end;
  2195. procedure ttypeconvnode._second_cstring_to_pchar;
  2196. begin
  2197. second_cstring_to_pchar;
  2198. end;
  2199. procedure ttypeconvnode._second_cstring_to_int;
  2200. begin
  2201. second_cstring_to_int;
  2202. end;
  2203. procedure ttypeconvnode._second_string_to_chararray;
  2204. begin
  2205. second_string_to_chararray;
  2206. end;
  2207. procedure ttypeconvnode._second_array_to_pointer;
  2208. begin
  2209. second_array_to_pointer;
  2210. end;
  2211. procedure ttypeconvnode._second_pointer_to_array;
  2212. begin
  2213. second_pointer_to_array;
  2214. end;
  2215. procedure ttypeconvnode._second_chararray_to_string;
  2216. begin
  2217. second_chararray_to_string;
  2218. end;
  2219. procedure ttypeconvnode._second_char_to_string;
  2220. begin
  2221. second_char_to_string;
  2222. end;
  2223. procedure ttypeconvnode._second_int_to_real;
  2224. begin
  2225. second_int_to_real;
  2226. end;
  2227. procedure ttypeconvnode._second_real_to_real;
  2228. begin
  2229. second_real_to_real;
  2230. end;
  2231. procedure ttypeconvnode._second_cord_to_pointer;
  2232. begin
  2233. second_cord_to_pointer;
  2234. end;
  2235. procedure ttypeconvnode._second_proc_to_procvar;
  2236. begin
  2237. second_proc_to_procvar;
  2238. end;
  2239. procedure ttypeconvnode._second_bool_to_int;
  2240. begin
  2241. second_bool_to_int;
  2242. end;
  2243. procedure ttypeconvnode._second_int_to_bool;
  2244. begin
  2245. second_int_to_bool;
  2246. end;
  2247. procedure ttypeconvnode._second_bool_to_bool;
  2248. begin
  2249. second_bool_to_bool;
  2250. end;
  2251. procedure ttypeconvnode._second_load_smallset;
  2252. begin
  2253. second_load_smallset;
  2254. end;
  2255. procedure ttypeconvnode._second_ansistring_to_pchar;
  2256. begin
  2257. second_ansistring_to_pchar;
  2258. end;
  2259. procedure ttypeconvnode._second_class_to_intf;
  2260. begin
  2261. second_class_to_intf;
  2262. end;
  2263. procedure ttypeconvnode._second_char_to_char;
  2264. begin
  2265. second_char_to_char;
  2266. end;
  2267. procedure ttypeconvnode._second_nothing;
  2268. begin
  2269. second_nothing;
  2270. end;
  2271. procedure ttypeconvnode.second_call_helper(c : tconverttype);
  2272. const
  2273. secondconvert : array[tconverttype] of pointer = (
  2274. @ttypeconvnode._second_nothing, {none}
  2275. @ttypeconvnode._second_nothing, {equal}
  2276. @ttypeconvnode._second_nothing, {not_possible}
  2277. @ttypeconvnode._second_nothing, {second_string_to_string, handled in resulttype pass }
  2278. @ttypeconvnode._second_char_to_string,
  2279. @ttypeconvnode._second_nothing, {char_to_charray}
  2280. @ttypeconvnode._second_nothing, { pchar_to_string, handled in resulttype pass }
  2281. @ttypeconvnode._second_nothing, {cchar_to_pchar}
  2282. @ttypeconvnode._second_cstring_to_pchar,
  2283. @ttypeconvnode._second_cstring_to_int,
  2284. @ttypeconvnode._second_ansistring_to_pchar,
  2285. @ttypeconvnode._second_string_to_chararray,
  2286. @ttypeconvnode._second_nothing, { chararray_to_string, handled in resulttype pass }
  2287. @ttypeconvnode._second_array_to_pointer,
  2288. @ttypeconvnode._second_pointer_to_array,
  2289. @ttypeconvnode._second_int_to_int,
  2290. @ttypeconvnode._second_int_to_bool,
  2291. @ttypeconvnode._second_nothing, { int_to_string, handled in resulttype pass }
  2292. @ttypeconvnode._second_bool_to_bool,
  2293. @ttypeconvnode._second_bool_to_int,
  2294. @ttypeconvnode._second_real_to_real,
  2295. @ttypeconvnode._second_int_to_real,
  2296. @ttypeconvnode._second_nothing, { real_to_currency, handled in resulttype pass }
  2297. @ttypeconvnode._second_proc_to_procvar,
  2298. @ttypeconvnode._second_nothing, { arrayconstructor_to_set }
  2299. @ttypeconvnode._second_nothing, { second_load_smallset, handled in first pass }
  2300. @ttypeconvnode._second_cord_to_pointer,
  2301. @ttypeconvnode._second_nothing, { interface 2 string }
  2302. @ttypeconvnode._second_nothing, { interface 2 guid }
  2303. @ttypeconvnode._second_class_to_intf,
  2304. @ttypeconvnode._second_char_to_char,
  2305. @ttypeconvnode._second_nothing, { normal_2_smallset }
  2306. @ttypeconvnode._second_nothing, { dynarray_2_openarray }
  2307. @ttypeconvnode._second_nothing, { pwchar_2_string }
  2308. @ttypeconvnode._second_nothing, { variant_2_dynarray }
  2309. @ttypeconvnode._second_nothing, { dynarray_2_variant}
  2310. @ttypeconvnode._second_nothing, { variant_2_enum }
  2311. @ttypeconvnode._second_nothing, { enum_2_variant }
  2312. @ttypeconvnode._second_nothing, { variant_2_interface }
  2313. @ttypeconvnode._second_nothing, { interface_2_variant }
  2314. @ttypeconvnode._second_nothing { array_2_dynarray }
  2315. );
  2316. type
  2317. tprocedureofobject = procedure of object;
  2318. var
  2319. r : packed record
  2320. proc : pointer;
  2321. obj : pointer;
  2322. end;
  2323. begin
  2324. { this is a little bit dirty but it works }
  2325. { and should be quite portable too }
  2326. r.proc:=secondconvert[c];
  2327. r.obj:=self;
  2328. tprocedureofobject(r)();
  2329. end;
  2330. {*****************************************************************************
  2331. TISNODE
  2332. *****************************************************************************}
  2333. constructor tisnode.create(l,r : tnode);
  2334. begin
  2335. inherited create(isn,l,r);
  2336. end;
  2337. function tisnode.det_resulttype:tnode;
  2338. var
  2339. paras: tcallparanode;
  2340. begin
  2341. result:=nil;
  2342. resulttypepass(left);
  2343. resulttypepass(right);
  2344. set_varstate(left,vs_read,[vsf_must_be_valid]);
  2345. set_varstate(right,vs_read,[vsf_must_be_valid]);
  2346. if codegenerror then
  2347. exit;
  2348. if (right.resulttype.def.deftype=classrefdef) then
  2349. begin
  2350. { left must be a class }
  2351. if is_class(left.resulttype.def) then
  2352. begin
  2353. { the operands must be related }
  2354. if (not(tobjectdef(left.resulttype.def).is_related(
  2355. tobjectdef(tclassrefdef(right.resulttype.def).pointertype.def)))) and
  2356. (not(tobjectdef(tclassrefdef(right.resulttype.def).pointertype.def).is_related(
  2357. tobjectdef(left.resulttype.def)))) then
  2358. CGMessage2(type_e_classes_not_related,left.resulttype.def.typename,
  2359. tclassrefdef(right.resulttype.def).pointertype.def.typename);
  2360. end
  2361. else
  2362. CGMessage1(type_e_class_type_expected,left.resulttype.def.typename);
  2363. { call fpc_do_is helper }
  2364. paras := ccallparanode.create(
  2365. left,
  2366. ccallparanode.create(
  2367. right,nil));
  2368. result := ccallnode.createintern('fpc_do_is',paras);
  2369. left := nil;
  2370. right := nil;
  2371. end
  2372. else if is_interface(right.resulttype.def) then
  2373. begin
  2374. { left is a class }
  2375. if is_class(left.resulttype.def) then
  2376. begin
  2377. { the operands must be related }
  2378. if not(assigned(tobjectdef(left.resulttype.def).implementedinterfaces) and
  2379. (tobjectdef(left.resulttype.def).implementedinterfaces.searchintf(right.resulttype.def)<>-1)) then
  2380. CGMessage2(type_e_classes_not_related,
  2381. FullTypeName(left.resulttype.def,right.resulttype.def),
  2382. FullTypeName(right.resulttype.def,left.resulttype.def))
  2383. end
  2384. { left is an interface }
  2385. else if is_interface(left.resulttype.def) then
  2386. begin
  2387. { the operands must be related }
  2388. if (not(tobjectdef(left.resulttype.def).is_related(tobjectdef(right.resulttype.def)))) and
  2389. (not(tobjectdef(right.resulttype.def).is_related(tobjectdef(left.resulttype.def)))) then
  2390. CGMessage2(type_e_classes_not_related,
  2391. FullTypeName(left.resulttype.def,right.resulttype.def),
  2392. FullTypeName(right.resulttype.def,left.resulttype.def));
  2393. end
  2394. else
  2395. CGMessage1(type_e_class_type_expected,left.resulttype.def.typename);
  2396. { call fpc_do_is helper }
  2397. paras := ccallparanode.create(
  2398. left,
  2399. ccallparanode.create(
  2400. right,nil));
  2401. result := ccallnode.createintern('fpc_do_is',paras);
  2402. left := nil;
  2403. right := nil;
  2404. end
  2405. else
  2406. CGMessage1(type_e_class_or_interface_type_expected,right.resulttype.def.typename);
  2407. resulttype:=booltype;
  2408. end;
  2409. function tisnode.pass_1 : tnode;
  2410. begin
  2411. internalerror(200204254);
  2412. result:=nil;
  2413. end;
  2414. { dummy pass_2, it will never be called, but we need one since }
  2415. { you can't instantiate an abstract class }
  2416. procedure tisnode.pass_2;
  2417. begin
  2418. end;
  2419. {*****************************************************************************
  2420. TASNODE
  2421. *****************************************************************************}
  2422. constructor tasnode.create(l,r : tnode);
  2423. begin
  2424. inherited create(asn,l,r);
  2425. call := nil;
  2426. end;
  2427. destructor tasnode.destroy;
  2428. begin
  2429. call.free;
  2430. inherited destroy;
  2431. end;
  2432. function tasnode.det_resulttype:tnode;
  2433. var
  2434. hp : tnode;
  2435. begin
  2436. result:=nil;
  2437. resulttypepass(right);
  2438. resulttypepass(left);
  2439. set_varstate(right,vs_read,[vsf_must_be_valid]);
  2440. set_varstate(left,vs_read,[vsf_must_be_valid]);
  2441. if codegenerror then
  2442. exit;
  2443. if (right.resulttype.def.deftype=classrefdef) then
  2444. begin
  2445. { left must be a class }
  2446. if is_class(left.resulttype.def) then
  2447. begin
  2448. { the operands must be related }
  2449. if (not(tobjectdef(left.resulttype.def).is_related(
  2450. tobjectdef(tclassrefdef(right.resulttype.def).pointertype.def)))) and
  2451. (not(tobjectdef(tclassrefdef(right.resulttype.def).pointertype.def).is_related(
  2452. tobjectdef(left.resulttype.def)))) then
  2453. CGMessage2(type_e_classes_not_related,
  2454. FullTypeName(left.resulttype.def,tclassrefdef(right.resulttype.def).pointertype.def),
  2455. FullTypeName(tclassrefdef(right.resulttype.def).pointertype.def,left.resulttype.def));
  2456. end
  2457. else
  2458. CGMessage1(type_e_class_type_expected,left.resulttype.def.typename);
  2459. resulttype:=tclassrefdef(right.resulttype.def).pointertype;
  2460. end
  2461. else if is_interface(right.resulttype.def) then
  2462. begin
  2463. { left is a class }
  2464. if not(is_class(left.resulttype.def) or
  2465. is_interfacecom(left.resulttype.def)) then
  2466. CGMessage1(type_e_class_or_cominterface_type_expected,left.resulttype.def.typename);
  2467. resulttype:=right.resulttype;
  2468. { load the GUID of the interface }
  2469. if (right.nodetype=typen) then
  2470. begin
  2471. if assigned(tobjectdef(right.resulttype.def).iidguid) then
  2472. begin
  2473. hp:=cguidconstnode.create(tobjectdef(right.resulttype.def).iidguid^);
  2474. right.free;
  2475. right:=hp;
  2476. end
  2477. else
  2478. internalerror(200206282);
  2479. resulttypepass(right);
  2480. end;
  2481. end
  2482. else
  2483. CGMessage1(type_e_class_or_interface_type_expected,right.resulttype.def.typename);
  2484. end;
  2485. function tasnode._getcopy: tnode;
  2486. begin
  2487. result := inherited _getcopy;
  2488. if assigned(call) then
  2489. tasnode(result).call := call.getcopy
  2490. else
  2491. tasnode(result).call := nil;
  2492. end;
  2493. function tasnode.pass_1 : tnode;
  2494. var
  2495. procname: string;
  2496. begin
  2497. result:=nil;
  2498. if not assigned(call) then
  2499. begin
  2500. if is_class(left.resulttype.def) and
  2501. (right.resulttype.def.deftype=classrefdef) then
  2502. call := ccallnode.createinternres('fpc_do_as',
  2503. ccallparanode.create(left,ccallparanode.create(right,nil)),
  2504. resulttype)
  2505. else
  2506. begin
  2507. if is_class(left.resulttype.def) then
  2508. procname := 'fpc_class_as_intf'
  2509. else
  2510. procname := 'fpc_intf_as';
  2511. call := ccallnode.createintern(procname,
  2512. ccallparanode.create(right,ccallparanode.create(left,nil)));
  2513. call := ctypeconvnode.create_internal(call,resulttype);
  2514. end;
  2515. left := nil;
  2516. right := nil;
  2517. firstpass(call);
  2518. if codegenerror then
  2519. exit;
  2520. expectloc:=call.expectloc;
  2521. registersint:=call.registersint;
  2522. registersfpu:=call.registersfpu;
  2523. {$ifdef SUPPORT_MMX}
  2524. registersmmx:=call.registersmmx;
  2525. {$endif SUPPORT_MMX}
  2526. end;
  2527. end;
  2528. begin
  2529. ctypeconvnode:=ttypeconvnode;
  2530. casnode:=tasnode;
  2531. cisnode:=tisnode;
  2532. end.