ncnv.pas 86 KB

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