ncnv.pas 115 KB

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