ncnv.pas 87 KB

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