ncnv.pas 199 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126
  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. ttypeconvnodeflag = (
  28. { the typeconvnode is a proc_2_procvar, generated internally by an
  29. address operator, such as @proc, Addr(proc), Ofs(proc) or Seg(proc),
  30. which is then going to be converted to a void pointer. Why does it
  31. matter? Because, on i8086 far code memory models you're allowed to
  32. take the address of a _near_ procedure as a void pointer (which the
  33. @ operator does in TP mode), but not as a procvar (in that case the
  34. procedure must be far). }
  35. tcnf_proc_2_procvar_2_voidpointer,
  36. { proc_2_procvar, generated internally by Ofs() }
  37. tcnf_proc_2_procvar_get_offset_only
  38. );
  39. ttypeconvnodeflags = set of ttypeconvnodeflag;
  40. ttypeconvnode = class(tunarynode)
  41. totypedef : tdef;
  42. totypedefderef : tderef;
  43. convtype : tconverttype;
  44. convnodeflags : ttypeconvnodeflags;
  45. warn_pointer_to_signed,
  46. assignment_side: boolean;
  47. constructor create(node : tnode;def:tdef);virtual;
  48. constructor create_explicit(node : tnode;def:tdef);
  49. constructor create_internal(node : tnode;def:tdef);
  50. constructor create_proc_to_procvar(node : tnode);
  51. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  52. procedure ppuwrite(ppufile:tcompilerppufile);override;
  53. procedure buildderefimpl;override;
  54. procedure derefimpl;override;
  55. function dogetcopy : tnode;override;
  56. procedure printnodeinfo(var t : text);override;
  57. {$ifdef DEBUG_NODE_XML}
  58. procedure XMLPrintNodeInfo(var T: Text); override;
  59. {$endif DEBUG_NODE_XML}
  60. function pass_1 : tnode;override;
  61. function pass_typecheck:tnode;override;
  62. function simplify(forinline : boolean):tnode; override;
  63. procedure mark_write;override;
  64. function docompare(p: tnode) : boolean; override;
  65. function retains_value_location:boolean;
  66. function assign_allowed:boolean;
  67. procedure second_call_helper(c : tconverttype);
  68. { always called before any other type conversion checks. If it
  69. returns true, the type conversion is ok and no further checks/
  70. handling are required. }
  71. function target_specific_general_typeconv: boolean;virtual;
  72. { called in case of a valid explicit type conversion. Can be used to
  73. replace this explicit type conversion with a different node, or to
  74. reject it after all }
  75. function target_specific_explicit_typeconv: boolean;virtual;
  76. { called when inserttypeconv is used to convert to a def that is equal
  77. according to compare_defs() }
  78. class function target_specific_need_equal_typeconv(fromdef, todef: tdef): boolean; virtual;
  79. protected
  80. function typecheck_int_to_int : tnode; virtual;
  81. function typecheck_cord_to_pointer : tnode; virtual;
  82. function typecheck_chararray_to_string : tnode; virtual;
  83. function typecheck_string_to_chararray : tnode; virtual;
  84. function typecheck_string_to_string : tnode; virtual;
  85. function typecheck_char_to_string : tnode; virtual;
  86. function typecheck_char_to_chararray : tnode; virtual;
  87. function typecheck_int_to_real : tnode; virtual;
  88. function typecheck_real_to_real : tnode; virtual;
  89. function typecheck_real_to_currency : tnode; virtual;
  90. function typecheck_cchar_to_pchar : tnode; virtual;
  91. function typecheck_cstring_to_pchar : tnode; virtual;
  92. function typecheck_cstring_to_int : tnode; virtual;
  93. function typecheck_char_to_char : tnode; virtual;
  94. function typecheck_arrayconstructor_to_set : tnode; virtual;
  95. function typecheck_set_to_set : tnode; virtual;
  96. function typecheck_pchar_to_string : tnode; virtual;
  97. function typecheck_interface_to_string : tnode; virtual;
  98. function typecheck_interface_to_guid : tnode; virtual;
  99. function typecheck_dynarray_to_openarray : tnode; virtual;
  100. function typecheck_pwchar_to_string : tnode; virtual;
  101. function typecheck_variant_to_dynarray : tnode; virtual;
  102. function typecheck_dynarray_to_variant : tnode; virtual;
  103. function typecheck_variant_to_enum : tnode; virtual;
  104. function typecheck_enum_to_variant : tnode; virtual;
  105. function typecheck_proc_to_procvar : tnode; virtual;
  106. function typecheck_variant_to_interface : tnode; virtual;
  107. function typecheck_interface_to_variant : tnode; virtual;
  108. function typecheck_array_2_dynarray : tnode; virtual;
  109. function typecheck_elem_2_openarray : tnode; virtual;
  110. function typecheck_arrayconstructor_to_dynarray : tnode; virtual;
  111. function typecheck_arrayconstructor_to_array : tnode; virtual;
  112. function typecheck_anonproc_2_funcref : tnode; virtual;
  113. function typecheck_procvar_2_funcref : tnode; virtual;
  114. private
  115. function _typecheck_int_to_int : tnode;
  116. function _typecheck_cord_to_pointer : tnode;
  117. function _typecheck_chararray_to_string : tnode;
  118. function _typecheck_string_to_chararray : tnode;
  119. function _typecheck_string_to_string : tnode;
  120. function _typecheck_char_to_string : tnode;
  121. function _typecheck_char_to_chararray : tnode;
  122. function _typecheck_int_to_real : tnode;
  123. function _typecheck_real_to_real : tnode;
  124. function _typecheck_real_to_currency : tnode;
  125. function _typecheck_cchar_to_pchar : tnode;
  126. function _typecheck_cstring_to_pchar : tnode;
  127. function _typecheck_cstring_to_int : tnode;
  128. function _typecheck_char_to_char : tnode;
  129. function _typecheck_arrayconstructor_to_set : tnode;
  130. function _typecheck_set_to_set : tnode;
  131. function _typecheck_pchar_to_string : tnode;
  132. function _typecheck_interface_to_string : tnode;
  133. function _typecheck_interface_to_guid : tnode;
  134. function _typecheck_dynarray_to_openarray : tnode;
  135. function _typecheck_pwchar_to_string : tnode;
  136. function _typecheck_variant_to_dynarray : tnode;
  137. function _typecheck_dynarray_to_variant : tnode;
  138. function _typecheck_variant_to_enum : tnode;
  139. function _typecheck_enum_to_variant : tnode;
  140. function _typecheck_proc_to_procvar : tnode;
  141. function _typecheck_variant_to_interface : tnode;
  142. function _typecheck_interface_to_variant : tnode;
  143. function _typecheck_array_2_dynarray : tnode;
  144. function _typecheck_elem_2_openarray : tnode;
  145. function _typecheck_arrayconstructor_to_dynarray : tnode;
  146. function _typecheck_arrayconstructor_to_array : tnode;
  147. function _typecheck_anonproc_to_funcref : tnode;
  148. function _typecheck_procvar_to_funcref : tnode;
  149. protected
  150. function first_int_to_int : tnode;virtual;
  151. function first_cstring_to_pchar : tnode;virtual;
  152. function first_cstring_to_int : tnode;virtual;
  153. function first_string_to_chararray : tnode;virtual;
  154. function first_char_to_string : tnode;virtual;
  155. function first_char_to_chararray : tnode; virtual;
  156. function first_nothing : tnode;virtual;
  157. function first_array_to_pointer : tnode;virtual;
  158. function first_int_to_real : tnode;virtual;
  159. function first_real_to_real : tnode;virtual;
  160. function first_pointer_to_array : tnode;virtual;
  161. function first_cchar_to_pchar : tnode;virtual;
  162. function first_bool_to_int : tnode;virtual;
  163. function first_int_to_bool : tnode;virtual;
  164. function first_bool_to_bool : tnode;virtual;
  165. function first_proc_to_procvar : tnode;virtual;
  166. function first_nil_to_methodprocvar : tnode;virtual;
  167. function first_set_to_set : tnode;virtual;
  168. function first_cord_to_pointer : tnode;virtual;
  169. function first_ansistring_to_pchar : tnode;virtual;
  170. function first_arrayconstructor_to_set : tnode;virtual;
  171. function first_class_to_intf : tnode;virtual;
  172. function first_char_to_char : tnode;virtual;
  173. function first_string_to_string : tnode;virtual;
  174. function first_call_helper(c : tconverttype) : tnode;
  175. function typecheck_call_helper(c : tconverttype) : tnode;
  176. private
  177. { these wrapper are necessary, because the first_* stuff is called }
  178. { through a table. Without the wrappers override wouldn't have }
  179. { any effect }
  180. function _first_int_to_int : tnode;
  181. function _first_cstring_to_pchar : tnode;
  182. function _first_cstring_to_int : tnode;
  183. function _first_string_to_chararray : tnode;
  184. function _first_char_to_string : tnode;
  185. function _first_char_to_chararray : tnode;
  186. function _first_nothing : tnode;
  187. function _first_array_to_pointer : tnode;
  188. function _first_int_to_real : tnode;
  189. function _first_real_to_real: tnode;
  190. function _first_pointer_to_array : tnode;
  191. function _first_cchar_to_pchar : tnode;
  192. function _first_bool_to_int : tnode;
  193. function _first_int_to_bool : tnode;
  194. function _first_bool_to_bool : tnode;
  195. function _first_proc_to_procvar : tnode;
  196. function _first_nil_to_methodprocvar : tnode;
  197. function _first_cord_to_pointer : tnode;
  198. function _first_ansistring_to_pchar : tnode;
  199. function _first_arrayconstructor_to_set : tnode;
  200. function _first_class_to_intf : tnode;
  201. function _first_char_to_char : tnode;
  202. function _first_set_to_set : tnode;
  203. function _first_string_to_string : tnode;
  204. procedure _second_int_to_int;virtual;
  205. procedure _second_string_to_string;virtual;
  206. procedure _second_cstring_to_pchar;virtual;
  207. procedure _second_cstring_to_int;virtual;
  208. procedure _second_string_to_chararray;virtual;
  209. procedure _second_array_to_pointer;virtual;
  210. procedure _second_pointer_to_array;virtual;
  211. procedure _second_chararray_to_string;virtual;
  212. procedure _second_char_to_string;virtual;
  213. procedure _second_int_to_real;virtual;
  214. procedure _second_real_to_real;virtual;
  215. procedure _second_cord_to_pointer;virtual;
  216. procedure _second_proc_to_procvar;virtual;
  217. procedure _second_nil_to_methodprocvar;virtual;
  218. procedure _second_bool_to_int;virtual;
  219. procedure _second_int_to_bool;virtual;
  220. procedure _second_bool_to_bool;virtual;
  221. procedure _second_set_to_set;virtual;
  222. procedure _second_ansistring_to_pchar;virtual;
  223. procedure _second_class_to_intf;virtual;
  224. procedure _second_char_to_char;virtual;
  225. procedure _second_elem_to_openarray;virtual;
  226. procedure _second_nothing; virtual;
  227. protected
  228. procedure second_int_to_int;virtual;abstract;
  229. procedure second_string_to_string;virtual;abstract;
  230. procedure second_cstring_to_pchar;virtual;abstract;
  231. procedure second_cstring_to_int;virtual;abstract;
  232. procedure second_string_to_chararray;virtual;abstract;
  233. procedure second_array_to_pointer;virtual;abstract;
  234. procedure second_pointer_to_array;virtual;abstract;
  235. procedure second_chararray_to_string;virtual;abstract;
  236. procedure second_char_to_string;virtual;abstract;
  237. procedure second_int_to_real;virtual;abstract;
  238. procedure second_real_to_real;virtual;abstract;
  239. procedure second_cord_to_pointer;virtual;abstract;
  240. procedure second_proc_to_procvar;virtual;abstract;
  241. procedure second_nil_to_methodprocvar;virtual;abstract;
  242. procedure second_bool_to_int;virtual;abstract;
  243. procedure second_int_to_bool;virtual;abstract;
  244. procedure second_bool_to_bool;virtual;abstract;
  245. procedure second_set_to_set;virtual;abstract;
  246. procedure second_ansistring_to_pchar;virtual;abstract;
  247. procedure second_class_to_intf;virtual;abstract;
  248. procedure second_char_to_char;virtual;abstract;
  249. procedure second_elem_to_openarray;virtual;abstract;
  250. procedure second_nothing; virtual;abstract;
  251. end;
  252. ttypeconvnodeclass = class of ttypeconvnode;
  253. { common functionality of as-nodes and is-nodes }
  254. tasisnode = class(tbinarynode)
  255. protected
  256. { if non-standard usage of as-nodes is possible, targets can override
  257. this method and return true in case the conditions are fulfilled }
  258. function target_specific_typecheck: boolean;virtual;
  259. public
  260. function pass_typecheck:tnode;override;
  261. end;
  262. tasnode = class(tasisnode)
  263. { as nodes cannot be translated directly into call nodes bcause:
  264. When using -CR, explicit class typecasts are replaced with as-nodes to perform
  265. class type checking. The problem is that if a typecasted class instance is
  266. passed as a var-parameter, then you cannot replace it with a function call. So the as-node
  267. a) call the as helper to perform the type checking
  268. b) still pass the original instance as parameter to var-parameters
  269. (and in general: to return it as the result of the as-node)
  270. so the call field is required
  271. }
  272. call: tnode;
  273. constructor create(l,r : tnode);virtual;
  274. constructor create_internal(l,r : tnode);virtual;
  275. function pass_1 : tnode;override;
  276. function dogetcopy: tnode;override;
  277. function docompare(p: tnode): boolean; override;
  278. destructor destroy; override;
  279. end;
  280. tasnodeclass = class of tasnode;
  281. tisnode = class(tasisnode)
  282. constructor create(l,r : tnode);virtual;
  283. constructor create_internal(l,r : tnode);virtual;
  284. function pass_1 : tnode;override;
  285. procedure pass_generate_code;override;
  286. end;
  287. tisnodeclass = class of tisnode;
  288. var
  289. ctypeconvnode : ttypeconvnodeclass = ttypeconvnode;
  290. casnode : tasnodeclass = tasnode;
  291. cisnode : tisnodeclass=tisnode;
  292. procedure inserttypeconv(var p:tnode;def:tdef);
  293. procedure inserttypeconv_explicit(var p:tnode;def:tdef);
  294. procedure inserttypeconv_internal(var p:tnode;def:tdef);
  295. procedure arrayconstructor_to_set(var p : tnode);inline;
  296. function arrayconstructor_to_set(p:tnode;freep:boolean):tnode;
  297. function arrayconstructor_can_be_set(p:tnode):boolean;
  298. procedure insert_varargstypeconv(var p : tnode; iscvarargs: boolean);
  299. function maybe_global_proc_to_nested(var fromnode: tnode; todef: tdef): boolean;
  300. implementation
  301. uses
  302. globtype,systems,constexp,compinnr,
  303. cutils,verbose,globals,widestr,ppu,
  304. symconst,symdef,symsym,symcpu,symtable,
  305. ncon,ncal,nset,nadd,nmem,nmat,nbas,nutils,ninl,nflw,
  306. psub,
  307. cgbase,procinfo,
  308. htypechk,blockutl,pparautl,procdefutil,pass_1,cpuinfo;
  309. {*****************************************************************************
  310. Helpers
  311. *****************************************************************************}
  312. type
  313. ttypeconvnodetype = (tct_implicit,tct_explicit,tct_internal);
  314. procedure do_inserttypeconv(var p: tnode;def: tdef; convtype: ttypeconvnodetype);
  315. begin
  316. if not assigned(p.resultdef) then
  317. begin
  318. typecheckpass(p);
  319. if codegenerror then
  320. exit;
  321. end;
  322. { don't insert superfluous type conversions, but
  323. in case of bitpacked accesses, the original type must
  324. remain too so that not too many/few bits are laoded.
  325. Also, in case the deftyp changes, don't ignore because lots of code
  326. expects that if the resultdef is set to e.g. stringdef, it remains
  327. that way (e.g., in case of Java where java_jlstring equals
  328. unicodestring according to equal_defs, but an add node for strings
  329. still expects the resultdef of the node to be a stringdef) }
  330. if equal_defs(p.resultdef,def) and
  331. (p.resultdef.typ=def.typ) and
  332. not is_bitpacked_access(p) and
  333. ((p.blocktype=bt_const) or
  334. not ctypeconvnode.target_specific_need_equal_typeconv(p.resultdef,def)) then
  335. begin
  336. { don't replace encoded string constants to rawbytestring encoding.
  337. preserve the codepage }
  338. if not (is_rawbytestring(def) and (p.nodetype=stringconstn)) then
  339. p.resultdef:=def
  340. end
  341. else
  342. begin
  343. case convtype of
  344. tct_implicit:
  345. p:=ctypeconvnode.create(p,def);
  346. tct_explicit:
  347. p:=ctypeconvnode.create_explicit(p,def);
  348. tct_internal:
  349. p:=ctypeconvnode.create_internal(p,def);
  350. end;
  351. p.fileinfo:=ttypeconvnode(p).left.fileinfo;
  352. typecheckpass(p);
  353. end;
  354. end;
  355. procedure inserttypeconv(var p:tnode;def:tdef);
  356. begin
  357. do_inserttypeconv(p,def,tct_implicit);
  358. end;
  359. procedure inserttypeconv_explicit(var p: tnode; def: tdef);
  360. begin
  361. do_inserttypeconv(p,def,tct_explicit);
  362. end;
  363. procedure inserttypeconv_internal(var p:tnode;def:tdef);
  364. begin
  365. do_inserttypeconv(p,def,tct_internal);
  366. end;
  367. {*****************************************************************************
  368. Array constructor to Set Conversion
  369. *****************************************************************************}
  370. procedure arrayconstructor_to_set(var p : tnode);
  371. begin
  372. p:=arrayconstructor_to_set(p,true);
  373. end;
  374. function arrayconstructor_to_set(p:tnode;freep:boolean):tnode;
  375. var
  376. constp : tsetconstnode;
  377. p2,p3,p4 : tnode;
  378. hdef : tdef;
  379. constset : Pconstset;
  380. constsetlo,
  381. constsethi : TConstExprInt;
  382. procedure update_constsethi(def:tdef; maybetruncenumrange: boolean);
  383. begin
  384. if (def.typ=orddef) and
  385. ((torddef(def).high>=constsethi) or
  386. (torddef(def).low <=constsetlo)) then
  387. begin
  388. if torddef(def).ordtype=uwidechar then
  389. begin
  390. constsethi:=255;
  391. constsetlo:=0;
  392. if hdef=nil then
  393. hdef:=def;
  394. end
  395. else
  396. begin
  397. if (torddef(def).high>=constsethi) then
  398. constsethi:=torddef(def).high;
  399. if (torddef(def).low<=constsetlo) then
  400. constsetlo:=torddef(def).low;
  401. if hdef=nil then
  402. begin
  403. if (constsethi>255) or
  404. (torddef(def).low<0) then
  405. hdef:=u8inttype
  406. else
  407. hdef:=def;
  408. end;
  409. if constsethi>255 then
  410. constsethi:=255;
  411. if constsetlo<0 then
  412. constsetlo:=0;
  413. end;
  414. end
  415. else if (def.typ=enumdef) and
  416. ((tenumdef(def).max>=constsethi) or
  417. (tenumdef(def).min<=constsetlo)) then
  418. begin
  419. if hdef=nil then
  420. hdef:=def;
  421. if (tenumdef(def).max>=constsethi) then
  422. constsethi:=tenumdef(def).max;
  423. if (tenumdef(def).min<=constsetlo) then
  424. constsetlo:=tenumdef(def).min;
  425. { for constant set elements, delphi allows the usage of elements of enumerations which
  426. have value>255 if there is no element with a value > 255 used }
  427. if (maybetruncenumrange) then
  428. begin
  429. if constsethi>255 then
  430. constsethi:=255;
  431. if constsetlo<0 then
  432. constsetlo:=0;
  433. end;
  434. end;
  435. end;
  436. procedure do_set(pos : longint);
  437. begin
  438. if (pos and not $ff)<>0 then
  439. begin
  440. Message(parser_e_illegal_set_expr);
  441. exit;
  442. end;
  443. if pos>constsethi then
  444. constsethi:=pos;
  445. if pos<constsetlo then
  446. constsetlo:=pos;
  447. if pos in constset^ then
  448. Message(parser_e_illegal_set_expr);
  449. include(constset^,pos);
  450. end;
  451. var
  452. l : Longint;
  453. lr,hr : TConstExprInt;
  454. hp : tarrayconstructornode;
  455. oldfilepos: tfileposinfo;
  456. begin
  457. { keep in sync with arrayconstructor_can_be_set }
  458. if p.nodetype<>arrayconstructorn then
  459. internalerror(200205105);
  460. new(constset);
  461. constset^:=[];
  462. hdef:=nil;
  463. { make sure to set constsetlo correctly for empty sets }
  464. if assigned(tarrayconstructornode(p).left) then
  465. constsetlo:=high(aint)
  466. else
  467. constsetlo:=0;
  468. constsethi:=0;
  469. constp:=csetconstnode.create(nil,hdef);
  470. constp.value_set:=constset;
  471. result:=constp;
  472. hp:=tarrayconstructornode(p);
  473. if assigned(hp.left) then
  474. begin
  475. while assigned(hp) do
  476. begin
  477. p4:=nil; { will contain the tree to create the set }
  478. {split a range into p2 and p3 }
  479. if hp.left.nodetype=arrayconstructorrangen then
  480. begin
  481. p2:=tarrayconstructorrangenode(hp.left).left;
  482. p3:=tarrayconstructorrangenode(hp.left).right;
  483. tarrayconstructorrangenode(hp.left).left:=nil;
  484. tarrayconstructorrangenode(hp.left).right:=nil;
  485. end
  486. else
  487. begin
  488. p2:=hp.left;
  489. hp.left:=nil;
  490. p3:=nil;
  491. end;
  492. typecheckpass(p2);
  493. set_varstate(p2,vs_read,[vsf_must_be_valid]);
  494. if assigned(p3) then
  495. begin
  496. typecheckpass(p3);
  497. set_varstate(p3,vs_read,[vsf_must_be_valid]);
  498. end;
  499. if codegenerror then
  500. break;
  501. oldfilepos:=current_filepos;
  502. current_filepos:=p2.fileinfo;
  503. case p2.resultdef.typ of
  504. enumdef,
  505. orddef:
  506. begin
  507. { widechars are not yet supported }
  508. if is_widechar(p2.resultdef) then
  509. begin
  510. inserttypeconv(p2,cansichartype);
  511. if (p2.nodetype<>ordconstn) then
  512. incompatibletypes(cwidechartype,cansichartype);
  513. end;
  514. getrange(p2.resultdef,lr,hr);
  515. if assigned(p3) then
  516. begin
  517. if is_widechar(p3.resultdef) then
  518. begin
  519. inserttypeconv(p3,cansichartype);
  520. if (p3.nodetype<>ordconstn) then
  521. begin
  522. current_filepos:=p3.fileinfo;
  523. incompatibletypes(cwidechartype,cansichartype);
  524. end;
  525. end;
  526. { this isn't good, you'll get problems with
  527. type t010 = 0..10;
  528. ts = set of t010;
  529. var s : ts;b : t010
  530. begin s:=[1,2,b]; end.
  531. if is_integer(p3^.resultdef) then
  532. begin
  533. inserttypeconv(p3,u8bitdef);
  534. end;
  535. }
  536. if assigned(hdef) and not(equal_defs(hdef,p3.resultdef)) then
  537. begin
  538. CGMessagePos(p3.fileinfo,type_e_typeconflict_in_set);
  539. end
  540. else
  541. begin
  542. if (p2.nodetype=ordconstn) and (p3.nodetype=ordconstn) then
  543. begin
  544. if not(is_integer(p3.resultdef)) then
  545. hdef:=p3.resultdef
  546. else
  547. begin
  548. inserttypeconv(p3,u8inttype);
  549. inserttypeconv(p2,u8inttype);
  550. end;
  551. if tordconstnode(p2).value.svalue>tordconstnode(p3).value.svalue then
  552. CGMessagePos(p2.fileinfo,type_w_empty_constant_range_set);
  553. for l:=tordconstnode(p2).value.svalue to tordconstnode(p3).value.svalue do
  554. do_set(l);
  555. p2.free;
  556. p3.free;
  557. end
  558. else
  559. begin
  560. update_constsethi(p2.resultdef,false);
  561. inserttypeconv(p2,hdef);
  562. update_constsethi(p3.resultdef,false);
  563. inserttypeconv(p3,hdef);
  564. if assigned(hdef) then
  565. inserttypeconv(p3,hdef)
  566. else
  567. inserttypeconv(p3,u8inttype);
  568. p4:=csetelementnode.create(p2,p3);
  569. end;
  570. end;
  571. end
  572. else
  573. begin
  574. { Single value }
  575. if p2.nodetype=ordconstn then
  576. begin
  577. if not(is_integer(p2.resultdef)) then
  578. update_constsethi(p2.resultdef,true);
  579. if assigned(hdef) then
  580. inserttypeconv(p2,hdef)
  581. else
  582. inserttypeconv(p2,u8inttype);
  583. do_set(tordconstnode(p2).value.svalue);
  584. p2.free;
  585. end
  586. else
  587. begin
  588. update_constsethi(p2.resultdef,false);
  589. if assigned(hdef) then
  590. inserttypeconv(p2,hdef)
  591. else
  592. inserttypeconv(p2,u8inttype);
  593. p4:=csetelementnode.create(p2,nil);
  594. end;
  595. end;
  596. end;
  597. stringdef :
  598. begin
  599. if (p2.nodetype<>stringconstn) then
  600. Message(parser_e_illegal_expression)
  601. { if we've already set elements which are constants }
  602. { throw an error }
  603. else if ((hdef=nil) and assigned(result)) or
  604. not(is_char(hdef)) then
  605. CGMessage(type_e_typeconflict_in_set)
  606. else
  607. for l:=1 to length(pshortstring(tstringconstnode(p2).value_str)^) do
  608. do_set(ord(pshortstring(tstringconstnode(p2).value_str)^[l]));
  609. if hdef=nil then
  610. hdef:=cansichartype;
  611. p2.free;
  612. end;
  613. else
  614. CGMessage(type_e_ordinal_expr_expected);
  615. end;
  616. { insert the set creation tree }
  617. if assigned(p4) then
  618. result:=caddnode.create(addn,result,p4);
  619. { load next and dispose current node }
  620. p2:=hp;
  621. hp:=tarrayconstructornode(tarrayconstructornode(p2).right);
  622. tarrayconstructornode(p2).right:=nil;
  623. if freep then
  624. p2.free;
  625. current_filepos:=oldfilepos;
  626. end;
  627. if (hdef=nil) then
  628. hdef:=u8inttype;
  629. end
  630. else
  631. begin
  632. { empty set [], only remove node }
  633. if freep then
  634. p.free;
  635. end;
  636. { set the initial set type }
  637. constp.resultdef:=csetdef.create(hdef,constsetlo.svalue,constsethi.svalue,true);
  638. { determine the resultdef for the tree }
  639. typecheckpass(result);
  640. end;
  641. function arrayconstructor_can_be_set(p:tnode):boolean;
  642. var
  643. p1,p2 : tnode;
  644. hdef : tdef;
  645. begin
  646. { keep in sync with arrayconstructor_to_set }
  647. if not assigned(p) then
  648. internalerror(2015050401);
  649. if not assigned(tarrayconstructornode(p).left) then
  650. begin
  651. if assigned(tarrayconstructornode(p).right) then
  652. internalerror(2015050103);
  653. result:=true;
  654. end
  655. else
  656. begin
  657. result:=false;
  658. hdef:=nil;
  659. while assigned(p) do
  660. begin
  661. if tarrayconstructornode(p).left.nodetype=arrayconstructorrangen then
  662. begin
  663. p1:=tarrayconstructorrangenode(tarrayconstructornode(p).left).left;
  664. p2:=tarrayconstructorrangenode(tarrayconstructornode(p).left).right;
  665. end
  666. else
  667. begin
  668. p1:=tarrayconstructornode(p).left;
  669. p2:=nil;
  670. end;
  671. case p1.resultdef.typ of
  672. orddef,
  673. enumdef:
  674. begin
  675. if is_widechar(p1.resultdef) then
  676. begin
  677. if p1.nodetype<>ordconstn then
  678. exit
  679. else if tordconstnode(p1).value.uvalue>high(byte) then
  680. exit;
  681. end;
  682. if assigned(p2) then
  683. begin
  684. if is_widechar(p2.resultdef) then
  685. begin
  686. if p2.nodetype<>ordconstn then
  687. exit
  688. else if tordconstnode(p2).value.uvalue>high(byte) then
  689. exit;
  690. end;
  691. { anything to exclude? }
  692. end
  693. else
  694. begin
  695. { anything to exclude? }
  696. end;
  697. end;
  698. stringdef:
  699. if p1.nodetype<>stringconstn then
  700. exit
  701. else if assigned(hdef) and not is_char(hdef) then
  702. exit;
  703. else
  704. exit;
  705. end;
  706. p:=tarrayconstructornode(p).right;
  707. end;
  708. result:=true;
  709. end;
  710. end;
  711. procedure insert_varargstypeconv(var p : tnode; iscvarargs: boolean);
  712. begin
  713. { procvars without arguments in variant arrays are always called by
  714. Delphi }
  715. if not(iscvarargs) then
  716. maybe_call_procvar(p,true);
  717. if not(iscvarargs) and
  718. (p.nodetype=stringconstn) and
  719. { don't cast to AnsiString if already casted to Wide/UnicodeString, issue #18266 }
  720. (tstringconstnode(p).cst_type in [cst_conststring,cst_shortstring,cst_longstring]) then
  721. p:=ctypeconvnode.create_internal(p,getansistringdef)
  722. else
  723. case p.resultdef.typ of
  724. enumdef :
  725. p:=ctypeconvnode.create_internal(p,s32inttype);
  726. arraydef :
  727. begin
  728. if is_chararray(p.resultdef) then
  729. p:=ctypeconvnode.create_internal(p,charpointertype)
  730. else
  731. if is_widechararray(p.resultdef) then
  732. p:=ctypeconvnode.create_internal(p,widecharpointertype)
  733. else
  734. CGMessagePos1(p.fileinfo,type_e_wrong_type_in_array_constructor,p.resultdef.typename);
  735. end;
  736. orddef :
  737. begin
  738. if is_integer(p.resultdef) and
  739. not(is_64bitint(p.resultdef)) then
  740. if not(m_delphi in current_settings.modeswitches) then
  741. p:=ctypeconvnode.create(p,s32inttype)
  742. else
  743. { delphi doesn't generate a range error when passing a
  744. cardinal >= $80000000, but since these are seen as
  745. longint on the callee side, this causes data loss;
  746. as a result, we require an explicit longint()
  747. typecast in FPC mode on the caller side if range
  748. checking should be disabled, but not in Delphi mode }
  749. p:=ctypeconvnode.create_internal(p,s32inttype)
  750. else if is_void(p.resultdef) then
  751. CGMessagePos1(p.fileinfo,type_e_wrong_type_in_array_constructor,p.resultdef.typename)
  752. else if iscvarargs and is_currency(p.resultdef)
  753. and (current_settings.fputype<>fpu_none) then
  754. p:=ctypeconvnode.create(p,s64floattype);
  755. end;
  756. floatdef :
  757. if not(iscvarargs) then
  758. begin
  759. if not(is_currency(p.resultdef)) then
  760. p:=ctypeconvnode.create(p,pbestrealtype^);
  761. end
  762. else
  763. begin
  764. if is_constrealnode(p) and
  765. not(nf_explicit in p.flags) then
  766. MessagePos(p.fileinfo,type_w_double_c_varargs);
  767. if (tfloatdef(p.resultdef).floattype in [s32real,s64currency]) or
  768. (is_constrealnode(p) and
  769. not(nf_explicit in p.flags)) then
  770. p:=ctypeconvnode.create(p,s64floattype);
  771. end;
  772. procvardef :
  773. p:=ctypeconvnode.create(p,voidpointertype);
  774. stringdef:
  775. if iscvarargs then
  776. p:=ctypeconvnode.create(p,charpointertype);
  777. variantdef:
  778. if iscvarargs then
  779. CGMessagePos1(p.fileinfo,type_e_wrong_type_in_array_constructor,p.resultdef.typename);
  780. { maybe warn in case it's not using "packrecords c"? }
  781. recorddef:
  782. if not iscvarargs then
  783. CGMessagePos1(p.fileinfo,type_e_wrong_type_in_array_constructor,p.resultdef.typename);
  784. pointerdef:
  785. ;
  786. classrefdef:
  787. if iscvarargs then
  788. p:=ctypeconvnode.create(p,voidpointertype);
  789. objectdef :
  790. if is_objc_class_or_protocol(p.resultdef) then
  791. p:=ctypeconvnode.create(p,voidpointertype)
  792. else if iscvarargs or
  793. is_object(p.resultdef) then
  794. CGMessagePos1(p.fileinfo,type_e_wrong_type_in_array_constructor,p.resultdef.typename)
  795. else
  796. else
  797. CGMessagePos1(p.fileinfo,type_e_wrong_type_in_array_constructor,p.resultdef.typename);
  798. end;
  799. typecheckpass(p);
  800. end;
  801. { in FPC mode, @procname immediately has to be evaluated as a
  802. procvar. If procname is global, then this will be a global
  803. procvar. Since converting global procvars to local procvars is
  804. not allowed (see point d in defcmp.proc_to_procvar_equal()),
  805. this results in errors when passing global procedures to local
  806. procvar parameters or assigning them to nested procvars. The
  807. solution is to remove the (wrong) conversion to a global procvar,
  808. and instead insert a conversion to the local procvar type. }
  809. function maybe_global_proc_to_nested(var fromnode: tnode; todef: tdef): boolean;
  810. var
  811. hp: tnode;
  812. begin
  813. result:=false;
  814. if (m_nested_procvars in current_settings.modeswitches) and
  815. not(m_tp_procvar in current_settings.modeswitches) and
  816. (todef.typ=procvardef) and
  817. is_nested_pd(tprocvardef(todef)) and
  818. (fromnode.nodetype=typeconvn) and
  819. (ttypeconvnode(fromnode).convtype=tc_proc_2_procvar) and
  820. not is_nested_pd(tprocvardef(fromnode.resultdef)) and
  821. (proc_to_procvar_equal(tprocdef(ttypeconvnode(fromnode).left.resultdef),tprocvardef(todef),false)>=te_convert_l1) then
  822. begin
  823. hp:=fromnode;
  824. fromnode:=ctypeconvnode.create_proc_to_procvar(ttypeconvnode(fromnode).left);
  825. ttypeconvnode(fromnode).totypedef:=todef;
  826. typecheckpass(fromnode);
  827. ttypeconvnode(hp).left:=nil;
  828. hp.free;
  829. result:=true;
  830. end;
  831. end;
  832. { similar as above, but for assigning @classtype.method to a
  833. procvar of object. pexpr.do_proc_call() stores the symtable of classtype
  834. in the loadnode so we can retrieve it here (rather than the symtable in
  835. which method was found, which may be a parent class) }
  836. function maybe_classmethod_to_methodprocvar(var fromnode: tnode; todef: tdef): boolean;
  837. var
  838. hp: tnode;
  839. begin
  840. result:=false;
  841. if not(m_tp_procvar in current_settings.modeswitches) and
  842. (todef.typ=procvardef) and
  843. is_methodpointer(tprocvardef(todef)) and
  844. (fromnode.nodetype=typeconvn) and
  845. (ttypeconvnode(fromnode).convtype=tc_proc_2_procvar) and
  846. is_methodpointer(fromnode.resultdef) and
  847. (po_classmethod in tprocvardef(fromnode.resultdef).procoptions) and
  848. not(po_staticmethod in tprocvardef(fromnode.resultdef).procoptions) and
  849. (proc_to_procvar_equal(tprocdef(ttypeconvnode(fromnode).left.resultdef),tprocvardef(todef),false)>=te_convert_l1) then
  850. begin
  851. hp:=fromnode;
  852. fromnode:=ttypeconvnode(fromnode).left;
  853. if (fromnode.nodetype=loadn) and
  854. not assigned(tloadnode(fromnode).left) then
  855. tloadnode(fromnode).set_mp(cloadvmtaddrnode.create(ctypenode.create(tdef(tloadnode(fromnode).symtable.defowner))));
  856. fromnode:=ctypeconvnode.create_proc_to_procvar(fromnode);
  857. ttypeconvnode(fromnode).totypedef:=todef;
  858. typecheckpass(fromnode);
  859. ttypeconvnode(hp).left:=nil;
  860. hp.free;
  861. result:=true;
  862. end;
  863. end;
  864. {*****************************************************************************
  865. TTYPECONVNODE
  866. *****************************************************************************}
  867. constructor ttypeconvnode.create(node : tnode;def:tdef);
  868. begin
  869. inherited create(typeconvn,node);
  870. convtype:=tc_none;
  871. convnodeflags:=[];
  872. totypedef:=def;
  873. if def=nil then
  874. internalerror(200103281);
  875. fileinfo:=node.fileinfo;
  876. {An attempt to convert the result of a floating point division
  877. (with the / operator) to an integer type will fail. Give a hint
  878. to use the div operator.}
  879. if (node.nodetype=slashn) and (def.typ=orddef) and not(is_currency(def)) then
  880. cgmessage(type_h_use_div_for_int);
  881. {In expressions like int64:=longint+longint, an integer overflow could be avoided
  882. by simply converting the operands to int64 first. Give a hint to do this.}
  883. if (node.nodetype in [addn,subn,muln]) and
  884. (def.typ=orddef) and (node.resultdef<>nil) and (node.resultdef.typ=orddef) and
  885. ((Torddef(node.resultdef).low>=Torddef(def).low) and (Torddef(node.resultdef).high<=Torddef(def).high)) and
  886. ((Torddef(node.resultdef).low>Torddef(def).low) or (Torddef(node.resultdef).high<Torddef(def).high)) then
  887. case node.nodetype of
  888. addn:
  889. cgmessage1(type_h_convert_add_operands_to_prevent_overflow,def.typename);
  890. subn:
  891. cgmessage1(type_h_convert_sub_operands_to_prevent_overflow,def.typename);
  892. muln:
  893. cgmessage1(type_h_convert_mul_operands_to_prevent_overflow,def.typename);
  894. else
  895. ;
  896. end;
  897. end;
  898. constructor ttypeconvnode.create_explicit(node : tnode;def:tdef);
  899. begin
  900. self.create(node,def);
  901. include(flags,nf_explicit);
  902. end;
  903. constructor ttypeconvnode.create_internal(node : tnode;def:tdef);
  904. begin
  905. self.create(node,def);
  906. { handle like explicit conversions }
  907. include(flags,nf_explicit);
  908. include(flags,nf_internal);
  909. end;
  910. constructor ttypeconvnode.create_proc_to_procvar(node : tnode);
  911. begin
  912. self.create(node,voidtype);
  913. convtype:=tc_proc_2_procvar;
  914. end;
  915. constructor ttypeconvnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  916. begin
  917. inherited ppuload(t,ppufile);
  918. ppufile.getderef(totypedefderef);
  919. convtype:=tconverttype(ppufile.getbyte);
  920. ppufile.getset(tppuset1(convnodeflags));
  921. end;
  922. procedure ttypeconvnode.ppuwrite(ppufile:tcompilerppufile);
  923. begin
  924. inherited ppuwrite(ppufile);
  925. ppufile.putderef(totypedefderef);
  926. ppufile.putbyte(byte(convtype));
  927. ppufile.putset(tppuset1(convnodeflags));
  928. end;
  929. procedure ttypeconvnode.buildderefimpl;
  930. begin
  931. inherited buildderefimpl;
  932. totypedefderef.build(totypedef);
  933. end;
  934. procedure ttypeconvnode.derefimpl;
  935. begin
  936. inherited derefimpl;
  937. totypedef:=tdef(totypedefderef.resolve);
  938. end;
  939. function ttypeconvnode.dogetcopy : tnode;
  940. var
  941. n : ttypeconvnode;
  942. begin
  943. n:=ttypeconvnode(inherited dogetcopy);
  944. n.convtype:=convtype;
  945. n.convnodeflags:=convnodeflags;
  946. n.totypedef:=totypedef;
  947. n.assignment_side:=assignment_side;
  948. dogetcopy:=n;
  949. end;
  950. procedure ttypeconvnode.printnodeinfo(var t : text);
  951. var
  952. first: Boolean;
  953. i: ttypeconvnodeflag;
  954. begin
  955. inherited printnodeinfo(t);
  956. write(t,', convtype = ',convtype);
  957. write(t,', convnodeflags = [');
  958. first:=true;
  959. for i:=low(ttypeconvnodeflag) to high(ttypeconvnodeflag) do
  960. if i in convnodeflags then
  961. begin
  962. if not first then
  963. write(t,',')
  964. else
  965. first:=false;
  966. write(t,i);
  967. end;
  968. write(t,']');
  969. end;
  970. {$ifdef DEBUG_NODE_XML}
  971. procedure TTypeConvNode.XMLPrintNodeInfo(var T: Text);
  972. var
  973. First: Boolean;
  974. i: TTypeConvNodeFlag;
  975. begin
  976. inherited XMLPrintNodeInfo(T);
  977. Write(T,' convtype="', convtype);
  978. First := True;
  979. for i := Low(TTypeConvNodeFlag) to High(TTypeConvNodeFlag) do
  980. if i in ConvNodeFlags then
  981. begin
  982. if First then
  983. begin
  984. Write(T, '" convnodeflags="', i);
  985. First := False;
  986. end
  987. else
  988. Write(T, ',', i);
  989. end;
  990. { If no flags were printed, this is the closing " for convtype }
  991. Write(T, '"');
  992. end;
  993. {$endif DEBUG_NODE_XML}
  994. function ttypeconvnode.typecheck_cord_to_pointer : tnode;
  995. begin
  996. result:=nil;
  997. if left.nodetype=ordconstn then
  998. begin
  999. { check if we have a valid pointer constant (JM) }
  1000. {$if sizeof(pointer) > sizeof(TConstPtrUInt)}
  1001. {$if sizeof(TConstPtrUInt) = 4}
  1002. if (tordconstnode(left).value < int64(low(longint))) or
  1003. (tordconstnode(left).value > int64(high(cardinal))) then
  1004. CGMessage(parser_e_range_check_error);
  1005. {$else} {$if sizeof(TConstPtrUInt) = 8}
  1006. if (tordconstnode(left).value < int64(low(int64))) or
  1007. (tordconstnode(left).value > int64(high(qword))) then
  1008. CGMessage(parser_e_range_check_error);
  1009. {$else}
  1010. internalerror(2001020801);
  1011. {$endif} {$endif}
  1012. {$endif}
  1013. if not(nf_explicit in flags) then
  1014. if (tordconstnode(left).value.svalue=0) then
  1015. CGMessage(type_w_zero_to_nil)
  1016. else
  1017. { in Delphi mode, these aren't caught in compare_defs_ext }
  1018. IncompatibleTypes(left.resultdef,resultdef);
  1019. result:=cpointerconstnode.create(TConstPtrUInt(tordconstnode(left).value.uvalue),resultdef);
  1020. end
  1021. else
  1022. internalerror(200104023);
  1023. end;
  1024. function ttypeconvnode.typecheck_chararray_to_string : tnode;
  1025. var
  1026. chartype : string[8];
  1027. newblock : tblocknode;
  1028. newstat : tstatementnode;
  1029. restemp : ttempcreatenode;
  1030. begin
  1031. if is_widechar(tarraydef(left.resultdef).elementdef) then
  1032. chartype:='widechar'
  1033. else
  1034. chartype:='char';
  1035. if tstringdef(resultdef).stringtype=st_shortstring then
  1036. begin
  1037. newblock:=internalstatements(newstat);
  1038. restemp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,false);
  1039. addstatement(newstat,restemp);
  1040. addstatement(newstat,ccallnode.createintern('fpc_'+chartype+'array_to_shortstr',
  1041. ccallparanode.create(cordconstnode.create(
  1042. ord(tarraydef(left.resultdef).lowrange=0),pasbool1type,false),
  1043. ccallparanode.create(left,ccallparanode.create(
  1044. ctemprefnode.create(restemp),nil)))));
  1045. addstatement(newstat,ctempdeletenode.create_normal_temp(restemp));
  1046. addstatement(newstat,ctemprefnode.create(restemp));
  1047. result:=newblock;
  1048. end
  1049. else if (tstringdef(resultdef).stringtype=st_ansistring) then
  1050. begin
  1051. result:=ccallnode.createinternres(
  1052. 'fpc_'+chartype+'array_to_'+tstringdef(resultdef).stringtypname,
  1053. ccallparanode.create(
  1054. cordconstnode.create(
  1055. ord(tarraydef(left.resultdef).lowrange=0),
  1056. pasbool1type,
  1057. false
  1058. ),
  1059. ccallparanode.create(
  1060. cordconstnode.create(
  1061. getparaencoding(resultdef),
  1062. u16inttype,
  1063. true
  1064. ),
  1065. ccallparanode.create(left,nil)
  1066. )
  1067. ),
  1068. resultdef
  1069. );
  1070. end
  1071. else
  1072. result:=ccallnode.createinternres(
  1073. 'fpc_'+chartype+'array_to_'+tstringdef(resultdef).stringtypname,
  1074. ccallparanode.create(cordconstnode.create(
  1075. ord(tarraydef(left.resultdef).lowrange=0),pasbool1type,false),
  1076. ccallparanode.create(left,nil)),resultdef);
  1077. left:=nil;
  1078. end;
  1079. function ttypeconvnode.typecheck_string_to_chararray : tnode;
  1080. var
  1081. newblock : tblocknode;
  1082. newstat : tstatementnode;
  1083. restemp : ttempcreatenode;
  1084. pchtemp : pchar;
  1085. arrsize : tcgint;
  1086. chartype : string[8];
  1087. begin
  1088. result := nil;
  1089. with tarraydef(resultdef) do
  1090. begin
  1091. if highrange<lowrange then
  1092. internalerror(2005010502);
  1093. arrsize := highrange-lowrange+1;
  1094. end;
  1095. if (left.nodetype = stringconstn) and
  1096. (tstringconstnode(left).cst_type=cst_conststring) then
  1097. begin
  1098. if (m_iso in current_settings.modeswitches) and (arrsize<>tstringconstnode(left).len) and
  1099. is_char(tarraydef(resultdef).elementdef) then
  1100. Message2(type_w_array_size_does_not_match_size_of_constant_string,tostr(tstringconstnode(left).len),tostr(arrsize));
  1101. { if the array of char is large enough we can use the string
  1102. constant directly. This is handled in ncgcnv }
  1103. if (arrsize>=tstringconstnode(left).len) and
  1104. is_char(tarraydef(resultdef).elementdef) then
  1105. begin
  1106. { pad the constant string with #0 to the array len }
  1107. { (2.0.x compatible) }
  1108. if (arrsize>tstringconstnode(left).len) then
  1109. begin
  1110. pchtemp:=concatansistrings(tstringconstnode(left).value_str,pchar(StringOfChar(#0,arrsize-tstringconstnode(left).len)),tstringconstnode(left).len,arrsize-tstringconstnode(left).len);
  1111. left.free;
  1112. left:=cstringconstnode.createpchar(pchtemp,arrsize,nil);
  1113. typecheckpass(left);
  1114. end;
  1115. exit;
  1116. end;
  1117. { Convert to wide/short/ansistring and call default helper }
  1118. if is_widechar(tarraydef(resultdef).elementdef) then
  1119. inserttypeconv(left,cunicodestringtype)
  1120. else
  1121. begin
  1122. if tstringconstnode(left).len>255 then
  1123. inserttypeconv(left,getansistringdef)
  1124. else
  1125. inserttypeconv(left,cshortstringtype);
  1126. end;
  1127. end;
  1128. if is_widechar(tarraydef(resultdef).elementdef) then
  1129. chartype:='widechar'
  1130. else
  1131. chartype:='char';
  1132. newblock:=internalstatements(newstat);
  1133. restemp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,false);
  1134. addstatement(newstat,restemp);
  1135. addstatement(newstat,ccallnode.createintern('fpc_'+tstringdef(left.resultdef).stringtypname+
  1136. '_to_'+chartype+'array',ccallparanode.create(left,ccallparanode.create(
  1137. ctemprefnode.create(restemp),nil))));
  1138. addstatement(newstat,ctempdeletenode.create_normal_temp(restemp));
  1139. addstatement(newstat,ctemprefnode.create(restemp));
  1140. result:=newblock;
  1141. left:=nil;
  1142. end;
  1143. function ttypeconvnode.typecheck_char_to_string : tnode;
  1144. var
  1145. procname: string[31];
  1146. para : tcallparanode;
  1147. hp : tstringconstnode;
  1148. ws : pcompilerwidestring;
  1149. sa : ansistring;
  1150. cw : tcompilerwidechar;
  1151. l : SizeUInt;
  1152. exprtype : tdef;
  1153. begin
  1154. result:=nil;
  1155. sa:='';
  1156. if (left.nodetype=ordconstn) and
  1157. ((tstringdef(resultdef).stringtype in [st_widestring,st_unicodestring,st_ansistring]) or
  1158. (torddef(left.resultdef).ordtype in [uchar,uwidechar])) then
  1159. begin
  1160. if (tstringdef(resultdef).stringtype in [st_widestring,st_unicodestring]) then
  1161. begin
  1162. initwidestring(ws);
  1163. if torddef(left.resultdef).ordtype=uwidechar then
  1164. concatwidestringchar(ws,tcompilerwidechar(tordconstnode(left).value.uvalue))
  1165. else
  1166. concatwidestringchar(ws,asciichar2unicode(chr(tordconstnode(left).value.uvalue)));
  1167. hp:=cstringconstnode.createunistr(ws);
  1168. hp.changestringtype(resultdef);
  1169. donewidestring(ws);
  1170. end
  1171. else
  1172. begin
  1173. if (torddef(left.resultdef).ordtype=uwidechar) then
  1174. begin
  1175. if (current_settings.sourcecodepage<>CP_UTF8) then
  1176. begin
  1177. if tordconstnode(left).value.uvalue>127 then
  1178. begin
  1179. Message(type_w_unicode_data_loss);
  1180. // compiler has different codepage than a system running an application
  1181. // to prevent wrong codepage and data loss we are converting unicode char
  1182. // using a helper routine. This is not delphi compatible behavior.
  1183. // Delphi converts UniocodeChar to ansistring at the compile time
  1184. // old behavior:
  1185. // hp:=cstringconstnode.createstr(unicode2asciichar(tcompilerwidechar(tordconstnode(left).value.uvalue)));
  1186. para:=ccallparanode.create(left,nil);
  1187. if tstringdef(resultdef).stringtype=st_ansistring then
  1188. para:=ccallparanode.create(cordconstnode.create(getparaencoding(resultdef),u16inttype,true),para);
  1189. result:=ccallnode.createinternres('fpc_uchar_to_'+tstringdef(resultdef).stringtypname,
  1190. para,resultdef);
  1191. left:=nil;
  1192. exit;
  1193. end
  1194. else
  1195. hp:=cstringconstnode.createstr(unicode2asciichar(tcompilerwidechar(tordconstnode(left).value.uvalue)));
  1196. end
  1197. else
  1198. begin
  1199. cw:=tcompilerwidechar(tordconstnode(left).value.uvalue);
  1200. SetLength(sa,5);
  1201. l:=UnicodeToUtf8(@(sa[1]),Length(sa),@cw,1);
  1202. SetLength(sa,l-1);
  1203. hp:=cstringconstnode.createstr(sa);
  1204. end
  1205. end
  1206. else
  1207. hp:=cstringconstnode.createstr(chr(tordconstnode(left).value.uvalue));
  1208. { output string consts in local ansistring encoding }
  1209. if is_ansistring(resultdef) and ((tstringdef(resultdef).encoding=0) or (tstringdef(resultdef).encoding=globals.CP_NONE)) then
  1210. tstringconstnode(hp).changestringtype(getansistringdef)
  1211. else
  1212. tstringconstnode(hp).changestringtype(resultdef);
  1213. end;
  1214. result:=hp;
  1215. end
  1216. else
  1217. { shortstrings are handled 'inline' (except for widechars) }
  1218. if (tstringdef(resultdef).stringtype<>st_shortstring) or
  1219. (torddef(left.resultdef).ordtype=uwidechar) or
  1220. (target_info.system in systems_managed_vm) then
  1221. begin
  1222. { parameter }
  1223. para:=ccallparanode.create(left,nil);
  1224. { encoding required? }
  1225. if tstringdef(resultdef).stringtype=st_ansistring then
  1226. para:=ccallparanode.create(cordconstnode.create(getparaencoding(resultdef),u16inttype,true),para);
  1227. { create the procname }
  1228. if torddef(left.resultdef).ordtype<>uwidechar then
  1229. begin
  1230. procname:='fpc_char_to_';
  1231. if tstringdef(resultdef).stringtype in [st_widestring,st_unicodestring] then
  1232. if nf_explicit in flags then
  1233. Message2(type_w_explicit_string_cast,left.resultdef.typename,resultdef.typename)
  1234. else
  1235. Message2(type_w_implicit_string_cast,left.resultdef.typename,resultdef.typename);
  1236. end
  1237. else
  1238. begin
  1239. procname:='fpc_uchar_to_';
  1240. if not (tstringdef(resultdef).stringtype in [st_widestring,st_unicodestring]) then
  1241. if nf_explicit in flags then
  1242. Message2(type_w_explicit_string_cast_loss,left.resultdef.typename,resultdef.typename)
  1243. else
  1244. Message2(type_w_implicit_string_cast_loss,left.resultdef.typename,resultdef.typename);
  1245. end;
  1246. procname:=procname+tstringdef(resultdef).stringtypname;
  1247. { and finally the call }
  1248. result:=ccallnode.createinternres(procname,para,resultdef);
  1249. left := nil;
  1250. end
  1251. else
  1252. begin
  1253. { use at least u16inttype }
  1254. {$ifdef cpu8bitalu}
  1255. exprtype:=u16inttype;
  1256. {$else cpu8bitalu}
  1257. exprtype:=uinttype;
  1258. {$endif cpu8bitalu}
  1259. { create word(byte(char) shl 8 or 1) for litte endian machines }
  1260. { and word(byte(char) or 256) for big endian machines }
  1261. left := ctypeconvnode.create_internal(left,exprtype);
  1262. if (target_info.endian = endian_little) then
  1263. left := caddnode.create(orn,
  1264. cshlshrnode.create(shln,left,cordconstnode.create(8,exprtype,false)),
  1265. cordconstnode.create(1,exprtype,false))
  1266. else
  1267. left := caddnode.create(orn,left,
  1268. cordconstnode.create(1 shl 8,exprtype,false));
  1269. left := ctypeconvnode.create_internal(left,u16inttype);
  1270. typecheckpass(left);
  1271. end;
  1272. end;
  1273. function ttypeconvnode.typecheck_string_to_string : tnode;
  1274. begin
  1275. result:=nil;
  1276. if (left.nodetype=stringconstn) and
  1277. (((tstringdef(resultdef).stringtype=st_ansistring) and
  1278. (tstringdef(resultdef).encoding<>CP_NONE)
  1279. )
  1280. ) and
  1281. (tstringdef(left.resultdef).stringtype in [st_unicodestring,st_widestring]) then
  1282. begin
  1283. tstringconstnode(left).changestringtype(resultdef);
  1284. Result:=left;
  1285. left:=nil;
  1286. end
  1287. else if (tstringdef(resultdef).stringtype=st_ansistring) and
  1288. (tstringdef(left.resultdef).stringtype=st_ansistring) and
  1289. (tstringdef(resultdef).encoding<>tstringdef(left.resultdef).encoding) then
  1290. begin
  1291. result:=ccallnode.createinternres(
  1292. 'fpc_ansistr_to_ansistr',
  1293. ccallparanode.create(
  1294. cordconstnode.create(
  1295. tstringdef(resultdef).encoding,
  1296. u16inttype,
  1297. true
  1298. ),
  1299. ccallparanode.create(left,nil)
  1300. ),
  1301. resultdef
  1302. );
  1303. left:=nil;
  1304. end
  1305. else if (left.nodetype=stringconstn) and
  1306. (tstringdef(left.resultdef).stringtype in [st_unicodestring,st_widestring]) and
  1307. (tstringdef(resultdef).stringtype=st_shortstring) then
  1308. begin
  1309. if not hasnonasciichars(pcompilerwidestring(tstringconstnode(left).value_str)) then
  1310. begin
  1311. tstringconstnode(left).changestringtype(resultdef);
  1312. Result:=left;
  1313. left:=nil;
  1314. end;
  1315. end
  1316. else if (tstringdef(left.resultdef).stringtype in [st_unicodestring,st_widestring]) and
  1317. not (tstringdef(resultdef).stringtype in [st_unicodestring,st_widestring]) then
  1318. begin
  1319. if nf_explicit in flags then
  1320. Message2(type_w_explicit_string_cast_loss,left.resultdef.typename,resultdef.typename)
  1321. else
  1322. Message2(type_w_implicit_string_cast_loss,left.resultdef.typename,resultdef.typename);
  1323. end
  1324. else if not (tstringdef(left.resultdef).stringtype in [st_unicodestring,st_widestring]) and
  1325. (tstringdef(resultdef).stringtype in [st_unicodestring,st_widestring]) then
  1326. begin
  1327. if nf_explicit in flags then
  1328. Message2(type_w_explicit_string_cast,left.resultdef.typename,resultdef.typename)
  1329. else
  1330. Message2(type_w_implicit_string_cast,left.resultdef.typename,resultdef.typename);
  1331. end
  1332. end;
  1333. function ttypeconvnode.typecheck_char_to_chararray : tnode;
  1334. begin
  1335. result:=nil;
  1336. end;
  1337. function ttypeconvnode.typecheck_char_to_char : tnode;
  1338. var
  1339. hp : tordconstnode;
  1340. begin
  1341. result:=nil;
  1342. if (left.nodetype=ordconstn) and
  1343. ((torddef(resultdef).ordtype<>uchar) or
  1344. (torddef(left.resultdef).ordtype<>uwidechar) or
  1345. (current_settings.sourcecodepage<>CP_UTF8))
  1346. then
  1347. begin
  1348. if (torddef(resultdef).ordtype=uchar) and
  1349. (torddef(left.resultdef).ordtype=uwidechar) and
  1350. (current_settings.sourcecodepage<>CP_UTF8) then
  1351. begin
  1352. if tordconstnode(left).value.uvalue>127 then
  1353. Message(type_w_unicode_data_loss);
  1354. hp:=cordconstnode.create(
  1355. ord(unicode2asciichar(tcompilerwidechar(tordconstnode(left).value.uvalue))),
  1356. cansichartype,true);
  1357. result:=hp;
  1358. end
  1359. else if (torddef(resultdef).ordtype=uwidechar) and
  1360. (torddef(left.resultdef).ordtype=uchar) then
  1361. begin
  1362. hp:=cordconstnode.create(
  1363. asciichar2unicode(chr(tordconstnode(left).value.uvalue)),
  1364. cwidechartype,true);
  1365. result:=hp;
  1366. end
  1367. else
  1368. internalerror(200105131);
  1369. exit;
  1370. end;
  1371. end;
  1372. function ttypeconvnode.typecheck_int_to_int : tnode;
  1373. var
  1374. v : TConstExprInt;
  1375. begin
  1376. result:=nil;
  1377. if left.nodetype=ordconstn then
  1378. begin
  1379. v:=tordconstnode(left).value;
  1380. if is_currency(resultdef) and
  1381. not(nf_internal in flags) then
  1382. v:=v*10000;
  1383. if (resultdef.typ=pointerdef) then
  1384. result:=cpointerconstnode.create(TConstPtrUInt(v.uvalue),resultdef)
  1385. else
  1386. begin
  1387. if is_currency(left.resultdef) then
  1388. begin
  1389. if not(nf_internal in flags) then
  1390. v:=v div 10000;
  1391. end
  1392. else if (resultdef.typ in [orddef,enumdef]) then
  1393. adaptrange(resultdef,v,([nf_internal,nf_absolute]*flags)<>[],nf_explicit in flags,cs_check_range in localswitches);
  1394. result:=cordconstnode.create(v,resultdef,false);
  1395. end;
  1396. end
  1397. else if left.nodetype=pointerconstn then
  1398. begin
  1399. v:=tpointerconstnode(left).value;
  1400. if (resultdef.typ=pointerdef) then
  1401. result:=cpointerconstnode.create(v.uvalue,resultdef)
  1402. else
  1403. begin
  1404. if is_currency(resultdef) and
  1405. not(nf_internal in flags) then
  1406. v:=v*10000;
  1407. result:=cordconstnode.create(v,resultdef,false);
  1408. end;
  1409. end
  1410. else
  1411. begin
  1412. if (is_currency(resultdef) or
  1413. is_currency(left.resultdef)) and
  1414. (nf_internal in flags) then
  1415. begin
  1416. include(flags,nf_is_currency)
  1417. end
  1418. { multiply by 10000 for currency. We need to use getcopy to pass
  1419. the argument because the current node is always disposed. Only
  1420. inserting the multiply in the left node is not possible because
  1421. it'll get in an infinite loop to convert int->currency }
  1422. else if is_currency(resultdef) then
  1423. begin
  1424. result:=caddnode.create(muln,getcopy,cordconstnode.create(10000,resultdef,false));
  1425. include(result.flags,nf_is_currency);
  1426. include(taddnode(result).left.flags,nf_internal);
  1427. end
  1428. else if is_currency(left.resultdef) then
  1429. begin
  1430. result:=cmoddivnode.create(divn,getcopy,cordconstnode.create(10000,resultdef,false));
  1431. include(result.flags,nf_is_currency);
  1432. include(tmoddivnode(result).left.flags,nf_internal);
  1433. end;
  1434. end;
  1435. end;
  1436. function ttypeconvnode.typecheck_int_to_real : tnode;
  1437. var
  1438. rv : bestreal;
  1439. begin
  1440. result:=nil;
  1441. if left.nodetype=ordconstn then
  1442. begin
  1443. rv:=tordconstnode(left).value;
  1444. if is_currency(resultdef) and
  1445. not(nf_internal in flags) then
  1446. rv:=rv*10000.0
  1447. else if is_currency(left.resultdef) and
  1448. not(nf_internal in flags) then
  1449. rv:=rv/10000.0;
  1450. result:=crealconstnode.create(rv,resultdef);
  1451. end
  1452. else
  1453. begin
  1454. if (is_currency(resultdef) or
  1455. is_currency(left.resultdef)) and
  1456. (nf_internal in flags) then
  1457. begin
  1458. include(flags,nf_is_currency)
  1459. end
  1460. { multiply by 10000 for currency. We need to use getcopy to pass
  1461. the argument because the current node is always disposed. Only
  1462. inserting the multiply in the left node is not possible because
  1463. it'll get in an infinite loop to convert int->currency }
  1464. else if is_currency(resultdef) then
  1465. begin
  1466. result:=caddnode.create(muln,getcopy,crealconstnode.create(10000.0,resultdef));
  1467. include(result.flags,nf_is_currency);
  1468. end
  1469. else if is_currency(left.resultdef) then
  1470. begin
  1471. result:=caddnode.create(slashn,getcopy,crealconstnode.create(10000.0,resultdef));
  1472. include(result.flags,nf_is_currency);
  1473. end;
  1474. end;
  1475. end;
  1476. function ttypeconvnode.typecheck_real_to_currency : tnode;
  1477. begin
  1478. if not is_currency(resultdef) then
  1479. internalerror(200304221);
  1480. result:=nil;
  1481. if not(nf_internal in flags) then
  1482. begin
  1483. left:=caddnode.create(muln,left,crealconstnode.create(10000.0,left.resultdef));
  1484. include(left.flags,nf_is_currency);
  1485. { Convert constants directly, else call Round() }
  1486. if left.nodetype=realconstn then
  1487. result:=cordconstnode.create(round(trealconstnode(left).value_real),resultdef,false)
  1488. else
  1489. begin
  1490. result:=cinlinenode.create(in_round_real,false,left);
  1491. { Internal type cast to currency }
  1492. result:=ctypeconvnode.create_internal(result,s64currencytype);
  1493. left:=nil;
  1494. end
  1495. end
  1496. else
  1497. begin
  1498. include(left.flags,nf_is_currency);
  1499. result:=left;
  1500. left:=nil;
  1501. end;
  1502. end;
  1503. function ttypeconvnode.typecheck_real_to_real : tnode;
  1504. begin
  1505. result:=nil;
  1506. if not(nf_internal in flags) then
  1507. begin
  1508. if is_currency(left.resultdef) and not(is_currency(resultdef)) then
  1509. begin
  1510. left:=caddnode.create(slashn,left,crealconstnode.create(10000.0,left.resultdef));
  1511. include(left.flags,nf_is_currency);
  1512. typecheckpass(left);
  1513. end
  1514. else
  1515. if is_currency(resultdef) and not(is_currency(left.resultdef)) then
  1516. begin
  1517. left:=caddnode.create(muln,left,crealconstnode.create(10000.0,left.resultdef));
  1518. include(left.flags,nf_is_currency);
  1519. include(flags,nf_is_currency);
  1520. typecheckpass(left);
  1521. end;
  1522. { comp is handled by the fpu but not a floating type point }
  1523. if is_fpucomp(resultdef) and not(is_fpucomp(left.resultdef)) and
  1524. not (nf_explicit in flags) then
  1525. Message(type_w_convert_real_2_comp);
  1526. end
  1527. else
  1528. include(flags,nf_is_currency);
  1529. end;
  1530. function ttypeconvnode.typecheck_cchar_to_pchar : tnode;
  1531. begin
  1532. result:=nil;
  1533. { handle any constants via cunicodestringtype because the compiler
  1534. cannot convert arbitrary unicodechar constants at compile time to
  1535. a shortstring (since it doesn't know the code page to use) }
  1536. inserttypeconv(left,cunicodestringtype);
  1537. { evaluate again, reset resultdef so the convert_typ
  1538. will be calculated again and cstring_to_pchar will
  1539. be used for futher conversion }
  1540. convtype:=tc_none;
  1541. result:=pass_typecheck;
  1542. end;
  1543. function ttypeconvnode.typecheck_cstring_to_pchar : tnode;
  1544. begin
  1545. result:=nil;
  1546. if is_pwidechar(resultdef) then
  1547. inserttypeconv(left,cunicodestringtype)
  1548. else
  1549. if is_pchar(resultdef) and
  1550. (is_widestring(left.resultdef) or
  1551. is_unicodestring(left.resultdef)) then
  1552. begin
  1553. inserttypeconv(left,getansistringdef);
  1554. { the second pass of second_cstring_to_pchar expects a }
  1555. { strinconstn, but this may become a call to the }
  1556. { widestring manager in case left contains "high ascii" }
  1557. if (left.nodetype<>stringconstn) then
  1558. begin
  1559. result:=left;
  1560. left:=nil;
  1561. end;
  1562. end;
  1563. end;
  1564. function ttypeconvnode.typecheck_cstring_to_int : tnode;
  1565. var
  1566. fcc : cardinal;
  1567. pb : pbyte;
  1568. begin
  1569. result:=nil;
  1570. if left.nodetype<>stringconstn then
  1571. internalerror(200510012);
  1572. if (m_mac in current_settings.modeswitches) and
  1573. is_integer(resultdef) and
  1574. (tstringconstnode(left).cst_type=cst_conststring) and
  1575. (tstringconstnode(left).len=4) then
  1576. begin
  1577. pb:=pbyte(tstringconstnode(left).value_str);
  1578. fcc:=(pb[0] shl 24) or (pb[1] shl 16) or (pb[2] shl 8) or pb[3];
  1579. result:=cordconstnode.create(fcc,u32inttype,false);
  1580. end
  1581. else
  1582. CGMessage2(type_e_illegal_type_conversion,left.resultdef.typename,resultdef.typename);
  1583. end;
  1584. function ttypeconvnode.typecheck_arrayconstructor_to_set : tnode;
  1585. var
  1586. hp : tnode;
  1587. begin
  1588. result:=nil;
  1589. if left.nodetype<>arrayconstructorn then
  1590. internalerror(5546);
  1591. { remove typeconv node }
  1592. hp:=left;
  1593. left:=nil;
  1594. { create a set constructor tree }
  1595. arrayconstructor_to_set(hp);
  1596. if is_emptyset(hp) then
  1597. begin
  1598. { enforce the result type for an empty set }
  1599. hp.resultdef:=resultdef;
  1600. result:=hp;
  1601. end
  1602. else if hp.resultdef<>resultdef then
  1603. begin
  1604. { the set might contain a subrange element (e.g. through a variable),
  1605. thus we need to insert another type conversion }
  1606. if nf_explicit in flags then
  1607. result:=ctypeconvnode.create_explicit(hp,totypedef)
  1608. else if nf_internal in flags then
  1609. result:=ctypeconvnode.create_internal(hp,totypedef)
  1610. else
  1611. result:=ctypeconvnode.create(hp,totypedef);
  1612. end
  1613. else
  1614. result:=hp;
  1615. end;
  1616. function ttypeconvnode.typecheck_set_to_set : tnode;
  1617. begin
  1618. result:=nil;
  1619. { constant sets can be converted by changing the type only }
  1620. if (left.nodetype=setconstn) then
  1621. begin
  1622. left.resultdef:=resultdef;
  1623. result:=left;
  1624. left:=nil;
  1625. exit;
  1626. end;
  1627. end;
  1628. function ttypeconvnode.typecheck_pchar_to_string : tnode;
  1629. var
  1630. newblock : tblocknode;
  1631. newstat : tstatementnode;
  1632. restemp : ttempcreatenode;
  1633. begin
  1634. if tstringdef(resultdef).stringtype=st_shortstring then
  1635. begin
  1636. newblock:=internalstatements(newstat);
  1637. restemp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,false);
  1638. addstatement(newstat,restemp);
  1639. addstatement(newstat,ccallnode.createintern('fpc_pchar_to_shortstr',ccallparanode.create(left,ccallparanode.create(
  1640. ctemprefnode.create(restemp),nil))));
  1641. addstatement(newstat,ctempdeletenode.create_normal_temp(restemp));
  1642. addstatement(newstat,ctemprefnode.create(restemp));
  1643. result:=newblock;
  1644. end
  1645. else if tstringdef(resultdef).stringtype=st_ansistring then
  1646. result := ccallnode.createinternres(
  1647. 'fpc_pchar_to_'+tstringdef(resultdef).stringtypname,
  1648. ccallparanode.create(
  1649. cordconstnode.create(getparaencoding(resultdef),u16inttype,true),
  1650. ccallparanode.create(left,nil)
  1651. ),
  1652. resultdef
  1653. )
  1654. else
  1655. result := ccallnode.createinternres(
  1656. 'fpc_pchar_to_'+tstringdef(resultdef).stringtypname,
  1657. ccallparanode.create(left,nil),resultdef);
  1658. left:=nil;
  1659. end;
  1660. function ttypeconvnode.typecheck_interface_to_string : tnode;
  1661. begin
  1662. if assigned(tobjectdef(left.resultdef).iidstr) then
  1663. begin
  1664. if not(oo_has_valid_guid in tobjectdef(left.resultdef).objectoptions) then
  1665. CGMessage1(type_e_interface_has_no_guid,tobjectdef(left.resultdef).typename);
  1666. result:=cstringconstnode.createstr(tobjectdef(left.resultdef).iidstr^);
  1667. tstringconstnode(result).changestringtype(cshortstringtype);
  1668. end
  1669. else
  1670. internalerror(2013112913);
  1671. end;
  1672. function ttypeconvnode.typecheck_interface_to_guid : tnode;
  1673. begin
  1674. if assigned(tobjectdef(left.resultdef).iidguid) then
  1675. begin
  1676. if not(oo_has_valid_guid in tobjectdef(left.resultdef).objectoptions) then
  1677. CGMessage1(type_e_interface_has_no_guid,tobjectdef(left.resultdef).typename);
  1678. result:=cguidconstnode.create(tobjectdef(left.resultdef).iidguid^);
  1679. end
  1680. else
  1681. internalerror(2013112914);
  1682. end;
  1683. function ttypeconvnode.typecheck_dynarray_to_openarray : tnode;
  1684. begin
  1685. if (actualtargetnode(@left)^.nodetype in [pointerconstn,niln]) then
  1686. CGMessage(type_e_no_addr_of_constant);
  1687. { a dynamic array is a pointer to an array, so to convert it to }
  1688. { an open array, we have to dereference it (JM) }
  1689. result := ctypeconvnode.create_internal(left,cpointerdef.getreusable(resultdef));
  1690. typecheckpass(result);
  1691. { left is reused }
  1692. left := nil;
  1693. result := cderefnode.create(result);
  1694. include(result.flags,nf_no_checkpointer);
  1695. end;
  1696. function ttypeconvnode.typecheck_pwchar_to_string : tnode;
  1697. var
  1698. newblock : tblocknode;
  1699. newstat : tstatementnode;
  1700. restemp : ttempcreatenode;
  1701. begin
  1702. if tstringdef(resultdef).stringtype=st_shortstring then
  1703. begin
  1704. newblock:=internalstatements(newstat);
  1705. restemp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,false);
  1706. addstatement(newstat,restemp);
  1707. addstatement(newstat,ccallnode.createintern('fpc_pwidechar_to_shortstr',ccallparanode.create(left,ccallparanode.create(
  1708. ctemprefnode.create(restemp),nil))));
  1709. addstatement(newstat,ctempdeletenode.create_normal_temp(restemp));
  1710. addstatement(newstat,ctemprefnode.create(restemp));
  1711. result:=newblock;
  1712. end
  1713. else if tstringdef(resultdef).stringtype=st_ansistring then
  1714. begin
  1715. result:=ccallnode.createinternres(
  1716. 'fpc_pwidechar_to_'+tstringdef(resultdef).stringtypname,
  1717. ccallparanode.create(
  1718. cordconstnode.create(
  1719. getparaencoding(resultdef),
  1720. u16inttype,
  1721. true
  1722. ),
  1723. ccallparanode.create(left,nil)
  1724. ),
  1725. resultdef
  1726. );
  1727. end
  1728. else
  1729. result := ccallnode.createinternres(
  1730. 'fpc_pwidechar_to_'+tstringdef(resultdef).stringtypname,
  1731. ccallparanode.create(left,nil),resultdef);
  1732. left:=nil;
  1733. end;
  1734. function ttypeconvnode.typecheck_variant_to_dynarray : tnode;
  1735. begin
  1736. result := ccallnode.createinternres(
  1737. 'fpc_variant_to_dynarray',
  1738. ccallparanode.create(caddrnode.create_internal(crttinode.create(tstoreddef(resultdef),initrtti,rdt_normal)),
  1739. ccallparanode.create(left,nil)
  1740. ),resultdef);
  1741. typecheckpass(result);
  1742. left:=nil;
  1743. end;
  1744. function ttypeconvnode.typecheck_dynarray_to_variant : tnode;
  1745. begin
  1746. result := ccallnode.createinternres(
  1747. 'fpc_dynarray_to_variant',
  1748. ccallparanode.create(caddrnode.create_internal(crttinode.create(tstoreddef(left.resultdef),initrtti,rdt_normal)),
  1749. ccallparanode.create(ctypeconvnode.create_explicit(left,voidpointertype),nil)
  1750. ),resultdef);
  1751. typecheckpass(result);
  1752. left:=nil;
  1753. end;
  1754. function ttypeconvnode.typecheck_variant_to_interface : tnode;
  1755. begin
  1756. if def_is_related(tobjectdef(resultdef),tobjectdef(search_system_type('IDISPATCH').typedef)) then
  1757. result := ccallnode.createinternres(
  1758. 'fpc_variant_to_idispatch',
  1759. ccallparanode.create(left,nil)
  1760. ,resultdef)
  1761. else
  1762. result := ccallnode.createinternres(
  1763. 'fpc_variant_to_interface',
  1764. ccallparanode.create(left,nil)
  1765. ,resultdef);
  1766. typecheckpass(result);
  1767. left:=nil;
  1768. end;
  1769. function ttypeconvnode.typecheck_interface_to_variant : tnode;
  1770. begin
  1771. if def_is_related(tobjectdef(left.resultdef),tobjectdef(search_system_type('IDISPATCH').typedef)) then
  1772. result := ccallnode.createinternres(
  1773. 'fpc_idispatch_to_variant',
  1774. ccallparanode.create(left,nil)
  1775. ,resultdef)
  1776. else
  1777. result := ccallnode.createinternres(
  1778. 'fpc_interface_to_variant',
  1779. ccallparanode.create(left,nil)
  1780. ,resultdef);
  1781. typecheckpass(result);
  1782. left:=nil;
  1783. end;
  1784. function ttypeconvnode.typecheck_variant_to_enum : tnode;
  1785. begin
  1786. result := ctypeconvnode.create_internal(left,sinttype);
  1787. result := ctypeconvnode.create_internal(result,resultdef);
  1788. typecheckpass(result);
  1789. { left is reused }
  1790. left := nil;
  1791. end;
  1792. function ttypeconvnode.typecheck_enum_to_variant : tnode;
  1793. begin
  1794. result := ctypeconvnode.create_internal(left,sinttype);
  1795. result := ctypeconvnode.create_internal(result,cvarianttype);
  1796. typecheckpass(result);
  1797. { left is reused }
  1798. left := nil;
  1799. end;
  1800. function ttypeconvnode.typecheck_array_2_dynarray : tnode;
  1801. var
  1802. newstatement : tstatementnode;
  1803. temp : ttempcreatenode;
  1804. temp2 : ttempcreatenode;
  1805. begin
  1806. { create statements with call to getmem+initialize }
  1807. result:=internalstatements(newstatement);
  1808. { create temp for result }
  1809. temp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,true);
  1810. addstatement(newstatement,temp);
  1811. { get temp for array of lengths }
  1812. temp2:=ctempcreatenode.create(sinttype,sinttype.size,tt_persistent,false);
  1813. addstatement(newstatement,temp2);
  1814. { one dimensional }
  1815. addstatement(newstatement,cassignmentnode.create(
  1816. ctemprefnode.create(temp2),
  1817. cordconstnode.create
  1818. (tarraydef(left.resultdef).highrange+1,s32inttype,true)));
  1819. { create call to fpc_dynarr_setlength }
  1820. addstatement(newstatement,ccallnode.createintern('fpc_dynarray_setlength',
  1821. ccallparanode.create(caddrnode.create_internal
  1822. (ctemprefnode.create(temp2)),
  1823. ccallparanode.create(cordconstnode.create
  1824. (1,s32inttype,true),
  1825. ccallparanode.create(caddrnode.create_internal
  1826. (crttinode.create(tstoreddef(resultdef),initrtti,rdt_normal)),
  1827. ccallparanode.create(
  1828. ctypeconvnode.create_internal(
  1829. ctemprefnode.create(temp),voidpointertype),
  1830. nil))))
  1831. ));
  1832. addstatement(newstatement,ctempdeletenode.create(temp2));
  1833. { copy ... }
  1834. addstatement(newstatement,cassignmentnode.create(
  1835. ctypeconvnode.create_internal(cderefnode.create(ctypeconvnode.create_internal(ctemprefnode.create(temp),voidpointertype)),left.resultdef),
  1836. left
  1837. ));
  1838. { left is reused }
  1839. left:=nil;
  1840. { the last statement should return the value as
  1841. location and type, this is done be referencing the
  1842. temp and converting it first from a persistent temp to
  1843. normal temp }
  1844. addstatement(newstatement,ctempdeletenode.create_normal_temp(temp));
  1845. addstatement(newstatement,ctemprefnode.create(temp));
  1846. end;
  1847. function ttypeconvnode.typecheck_elem_2_openarray : tnode;
  1848. begin
  1849. result:=nil;
  1850. end;
  1851. function ttypeconvnode.typecheck_arrayconstructor_to_dynarray : tnode;
  1852. var
  1853. newstatement,
  1854. assstatement : tstatementnode;
  1855. arrnode : ttempcreatenode;
  1856. temp2 : ttempcreatenode;
  1857. assnode : tnode;
  1858. paracount : integer;
  1859. elemnode : tarrayconstructornode;
  1860. begin
  1861. { assignment of []? }
  1862. if (
  1863. (left.nodetype=arrayconstructorn) and
  1864. not assigned(tarrayconstructornode(left).left)
  1865. ) or
  1866. is_emptyset(left)
  1867. then
  1868. begin
  1869. result:=cnilnode.create;
  1870. exit;
  1871. end;
  1872. if resultdef.typ<>arraydef then
  1873. internalerror(2017050102);
  1874. tarrayconstructornode(left).force_type(tarraydef(resultdef).elementdef);
  1875. result:=internalstatements(newstatement);
  1876. { create temp for result }
  1877. arrnode:=ctempcreatenode.create(totypedef,totypedef.size,tt_persistent,true);
  1878. addstatement(newstatement,arrnode);
  1879. paracount:=0;
  1880. { create an assignment call for each element }
  1881. assnode:=internalstatements(assstatement);
  1882. if left.nodetype=arrayconstructorrangen then
  1883. internalerror(2016021902);
  1884. elemnode:=tarrayconstructornode(left);
  1885. while assigned(elemnode) do
  1886. begin
  1887. { arr[i] := param_i }
  1888. if not assigned(elemnode.left) then
  1889. internalerror(2017050103);
  1890. addstatement(assstatement,
  1891. cassignmentnode.create(
  1892. cvecnode.create(
  1893. ctemprefnode.create(arrnode),
  1894. cordconstnode.create(paracount,tarraydef(totypedef).rangedef,false)),
  1895. elemnode.left));
  1896. elemnode.left:=nil;
  1897. inc(paracount);
  1898. elemnode:=tarrayconstructornode(elemnode.right);
  1899. if assigned(elemnode) and (elemnode.nodetype<>arrayconstructorn) then
  1900. internalerror(2016021903);
  1901. end;
  1902. { get temp for array of lengths }
  1903. temp2:=ctempcreatenode.create_value(sinttype,sinttype.size,tt_persistent,false,cordconstnode.create(paracount,s32inttype,true));
  1904. addstatement(newstatement,temp2);
  1905. { create call to fpc_dynarr_setlength }
  1906. addstatement(newstatement,ccallnode.createintern('fpc_dynarray_setlength',
  1907. ccallparanode.create(caddrnode.create_internal
  1908. (ctemprefnode.create(temp2)),
  1909. ccallparanode.create(cordconstnode.create
  1910. (1,s32inttype,true),
  1911. ccallparanode.create(caddrnode.create_internal
  1912. (crttinode.create(tstoreddef(totypedef),initrtti,rdt_normal)),
  1913. ccallparanode.create(
  1914. ctypeconvnode.create_internal(
  1915. ctemprefnode.create(arrnode),voidpointertype),
  1916. nil))))
  1917. ));
  1918. { add assignment statememnts }
  1919. addstatement(newstatement,ctempdeletenode.create(temp2));
  1920. addstatement(newstatement,assnode);
  1921. { the last statement should return the value as
  1922. location and type, this is done be referencing the
  1923. temp and converting it first from a persistent temp to
  1924. normal temp }
  1925. addstatement(newstatement,ctempdeletenode.create_normal_temp(arrnode));
  1926. addstatement(newstatement,ctemprefnode.create(arrnode));
  1927. end;
  1928. function ttypeconvnode.typecheck_arrayconstructor_to_array : tnode;
  1929. var
  1930. newstatement,
  1931. assstatement : tstatementnode;
  1932. arrnode : ttempcreatenode;
  1933. temp2 : ttempcreatenode;
  1934. assnode : tnode;
  1935. paracount : integer;
  1936. elemnode : tarrayconstructornode;
  1937. begin
  1938. tarrayconstructornode(left).force_type(tarraydef(resultdef).elementdef);
  1939. result:=internalstatements(newstatement);
  1940. { create temp for result }
  1941. arrnode:=ctempcreatenode.create(totypedef,totypedef.size,tt_persistent,true);
  1942. addstatement(newstatement,arrnode);
  1943. paracount:=0;
  1944. { create an assignment call for each element }
  1945. assnode:=internalstatements(assstatement);
  1946. if left.nodetype=arrayconstructorrangen then
  1947. internalerror(2020041402);
  1948. elemnode:=tarrayconstructornode(left);
  1949. while assigned(elemnode) do
  1950. begin
  1951. { arr[i] := param_i }
  1952. if not assigned(elemnode.left) then
  1953. internalerror(2020041403);
  1954. addstatement(assstatement,
  1955. cassignmentnode.create(
  1956. cvecnode.create(
  1957. ctemprefnode.create(arrnode),
  1958. cordconstnode.create(paracount+tarraydef(totypedef).lowrange,tarraydef(totypedef).rangedef,false)),
  1959. elemnode.left));
  1960. elemnode.left:=nil;
  1961. inc(paracount);
  1962. elemnode:=tarrayconstructornode(elemnode.right);
  1963. if assigned(elemnode) and (elemnode.nodetype<>arrayconstructorn) then
  1964. internalerror(2020041404);
  1965. end;
  1966. { get temp for array of lengths }
  1967. temp2:=ctempcreatenode.create_value(sinttype,sinttype.size,tt_persistent,false,cordconstnode.create(paracount,s32inttype,true));
  1968. addstatement(newstatement,temp2);
  1969. { add assignment statememnts }
  1970. addstatement(newstatement,ctempdeletenode.create(temp2));
  1971. addstatement(newstatement,assnode);
  1972. { the last statement should return the value as
  1973. location and type, this is done be referencing the
  1974. temp and converting it first from a persistent temp to
  1975. normal temp }
  1976. addstatement(newstatement,ctempdeletenode.create_normal_temp(arrnode));
  1977. addstatement(newstatement,ctemprefnode.create(arrnode));
  1978. end;
  1979. function ttypeconvnode._typecheck_int_to_int : tnode;
  1980. begin
  1981. result := typecheck_int_to_int;
  1982. end;
  1983. function ttypeconvnode._typecheck_cord_to_pointer : tnode;
  1984. begin
  1985. result := typecheck_cord_to_pointer;
  1986. end;
  1987. function ttypeconvnode._typecheck_chararray_to_string : tnode;
  1988. begin
  1989. result := typecheck_chararray_to_string;
  1990. end;
  1991. function ttypeconvnode._typecheck_string_to_chararray : tnode;
  1992. begin
  1993. result := typecheck_string_to_chararray;
  1994. end;
  1995. function ttypeconvnode._typecheck_string_to_string: tnode;
  1996. begin
  1997. result := typecheck_string_to_string;
  1998. end;
  1999. function ttypeconvnode._typecheck_char_to_string : tnode;
  2000. begin
  2001. result := typecheck_char_to_string;
  2002. end;
  2003. function ttypeconvnode._typecheck_char_to_chararray : tnode;
  2004. begin
  2005. result := typecheck_char_to_chararray;
  2006. end;
  2007. function ttypeconvnode._typecheck_int_to_real : tnode;
  2008. begin
  2009. result := typecheck_int_to_real;
  2010. end;
  2011. function ttypeconvnode._typecheck_real_to_real : tnode;
  2012. begin
  2013. result := typecheck_real_to_real;
  2014. end;
  2015. function ttypeconvnode._typecheck_real_to_currency : tnode;
  2016. begin
  2017. result := typecheck_real_to_currency;
  2018. end;
  2019. function ttypeconvnode._typecheck_cchar_to_pchar : tnode;
  2020. begin
  2021. result := typecheck_cchar_to_pchar;
  2022. end;
  2023. function ttypeconvnode._typecheck_cstring_to_pchar : tnode;
  2024. begin
  2025. result := typecheck_cstring_to_pchar;
  2026. end;
  2027. function ttypeconvnode._typecheck_cstring_to_int : tnode;
  2028. begin
  2029. result := typecheck_cstring_to_int;
  2030. end;
  2031. function ttypeconvnode._typecheck_char_to_char : tnode;
  2032. begin
  2033. result := typecheck_char_to_char;
  2034. end;
  2035. function ttypeconvnode._typecheck_arrayconstructor_to_set : tnode;
  2036. begin
  2037. result := typecheck_arrayconstructor_to_set;
  2038. end;
  2039. function ttypeconvnode._typecheck_set_to_set : tnode;
  2040. begin
  2041. result := typecheck_set_to_set;
  2042. end;
  2043. function ttypeconvnode._typecheck_pchar_to_string : tnode;
  2044. begin
  2045. result := typecheck_pchar_to_string;
  2046. end;
  2047. function ttypeconvnode._typecheck_interface_to_string : tnode;
  2048. begin
  2049. result := typecheck_interface_to_string;
  2050. end;
  2051. function ttypeconvnode._typecheck_interface_to_guid : tnode;
  2052. begin
  2053. result := typecheck_interface_to_guid;
  2054. end;
  2055. function ttypeconvnode._typecheck_dynarray_to_openarray : tnode;
  2056. begin
  2057. result := typecheck_dynarray_to_openarray;
  2058. end;
  2059. function ttypeconvnode._typecheck_pwchar_to_string : tnode;
  2060. begin
  2061. result := typecheck_pwchar_to_string;
  2062. end;
  2063. function ttypeconvnode._typecheck_variant_to_dynarray : tnode;
  2064. begin
  2065. result := typecheck_variant_to_dynarray;
  2066. end;
  2067. function ttypeconvnode._typecheck_dynarray_to_variant : tnode;
  2068. begin
  2069. result := typecheck_dynarray_to_variant;
  2070. end;
  2071. function ttypeconvnode._typecheck_variant_to_enum : tnode;
  2072. begin
  2073. result := typecheck_variant_to_enum;
  2074. end;
  2075. function ttypeconvnode._typecheck_enum_to_variant : tnode;
  2076. begin
  2077. result := typecheck_enum_to_variant;
  2078. end;
  2079. function ttypeconvnode._typecheck_proc_to_procvar : tnode;
  2080. begin
  2081. result := typecheck_proc_to_procvar;
  2082. end;
  2083. function ttypeconvnode._typecheck_variant_to_interface : tnode;
  2084. begin
  2085. result := typecheck_variant_to_interface;
  2086. end;
  2087. function ttypeconvnode._typecheck_interface_to_variant : tnode;
  2088. begin
  2089. result := typecheck_interface_to_variant;
  2090. end;
  2091. function ttypeconvnode._typecheck_array_2_dynarray : tnode;
  2092. begin
  2093. result := typecheck_array_2_dynarray;
  2094. end;
  2095. function ttypeconvnode._typecheck_elem_2_openarray : tnode;
  2096. begin
  2097. result := typecheck_elem_2_openarray;
  2098. end;
  2099. function ttypeconvnode._typecheck_arrayconstructor_to_dynarray : tnode;
  2100. begin
  2101. result:=typecheck_arrayconstructor_to_dynarray;
  2102. end;
  2103. function ttypeconvnode._typecheck_arrayconstructor_to_array : tnode;
  2104. begin
  2105. result:=typecheck_arrayconstructor_to_array;
  2106. end;
  2107. function ttypeconvnode._typecheck_procvar_to_funcref : tnode;
  2108. begin
  2109. result:=typecheck_procvar_2_funcref;
  2110. end;
  2111. function ttypeconvnode._typecheck_anonproc_to_funcref : tnode;
  2112. begin
  2113. result:=typecheck_anonproc_2_funcref;
  2114. end;
  2115. function ttypeconvnode.target_specific_general_typeconv: boolean;
  2116. begin
  2117. result:=false;
  2118. end;
  2119. function ttypeconvnode.target_specific_explicit_typeconv: boolean;
  2120. begin
  2121. result:=false;
  2122. end;
  2123. class function ttypeconvnode.target_specific_need_equal_typeconv(fromdef, todef: tdef): boolean;
  2124. begin
  2125. result:=false;
  2126. end;
  2127. type
  2128. tsym_mapping = record
  2129. oldsym:tsym;
  2130. newsym:tsym;
  2131. end;
  2132. psym_mapping = ^tsym_mapping;
  2133. function replace_self_sym(var n:tnode;arg:pointer):foreachnoderesult;
  2134. var
  2135. mapping : psym_mapping absolute arg;
  2136. ld : tloadnode;
  2137. begin
  2138. if n.nodetype=loadn then
  2139. begin
  2140. ld:=tloadnode(n);
  2141. if ld.symtableentry=mapping^.oldsym then
  2142. begin
  2143. ld.symtableentry:=mapping^.newsym;
  2144. { make sure that the node is processed again }
  2145. ld.resultdef:=nil;
  2146. if assigned(ld.left) then
  2147. begin
  2148. { no longer loaded through the frame pointer }
  2149. ld.left.free;
  2150. ld.left:=nil;
  2151. end;
  2152. typecheckpass(n);
  2153. end;
  2154. end;
  2155. result:=fen_true;
  2156. end;
  2157. function ttypeconvnode.typecheck_proc_to_procvar : tnode;
  2158. function is_self_sym(sym:tsym):boolean;
  2159. begin
  2160. result:=(sym.typ in [localvarsym,paravarsym]) and
  2161. (vo_is_self in tabstractvarsym(sym).varoptions);
  2162. end;
  2163. var
  2164. pd : tabstractprocdef;
  2165. copytype : tproccopytyp;
  2166. source: pnode;
  2167. fpsym,
  2168. selfsym,
  2169. sym : tsym;
  2170. mapping : tsym_mapping;
  2171. pi : tprocinfo;
  2172. i : longint;
  2173. begin
  2174. result:=nil;
  2175. pd:=tabstractprocdef(left.resultdef);
  2176. { create procvardef (default for create_proc_to_procvar is voiddef,
  2177. but if later a regular inserttypeconvnode() is used to insert a type
  2178. conversion to the actual procvardef, totypedef will be set to the
  2179. real procvartype that we are converting to) }
  2180. if assigned(totypedef) and
  2181. (totypedef.typ=procvardef) then
  2182. begin
  2183. { have to do this in typecheckpass so that it's triggered for
  2184. typed constant declarations }
  2185. if po_is_block in tprocvardef(totypedef).procoptions then
  2186. begin
  2187. { can only convert from procdef to procvardef, but in the mean
  2188. time other type conversions may have been inserted (pointers,
  2189. proc2procvar, ...) }
  2190. source:=actualtargetnode(@left);
  2191. while (source^.nodetype=typeconvn) and
  2192. (ttypeconvnode(source^).convtype=tc_proc_2_procvar) and
  2193. (is_void(source^.resultdef) or
  2194. (source^.resultdef.typ=procvardef)) do
  2195. begin
  2196. { won't skip proc2procvar }
  2197. source:=actualtargetnode(@ttypeconvnode(source^).left);
  2198. end;
  2199. if (source^.nodetype=loadn) and
  2200. (source^.resultdef.typ=procdef) and
  2201. not is_nested_pd(tprocdef(source^.resultdef)) and
  2202. not is_objcclass(tdef(source^.resultdef.owner.defowner)) then
  2203. begin
  2204. result:=generate_block_for_procaddr(tloadnode(source^));
  2205. exit;
  2206. end
  2207. else
  2208. CGMessage2(type_e_illegal_type_conversion,left.resultdef.typename,resultdef.typename);
  2209. end
  2210. else if (pd.typ=procdef) and
  2211. (po_anonymous in pd.procoptions) then
  2212. begin
  2213. if left.nodetype<>loadn then
  2214. internalerror(2021062402);
  2215. { get rid of any potential framepointer loading; if it's necessary
  2216. (for a nested procvar for example) it will be added again }
  2217. if assigned(tloadnode(left).left) and (tloadnode(left).left.nodetype=loadparentfpn) then
  2218. begin
  2219. tloadnode(left).left.free;
  2220. tloadnode(left).left:=nil;
  2221. tloadnode(left).resultdef:=nil;
  2222. end;
  2223. if tprocvardef(totypedef).is_methodpointer then
  2224. begin
  2225. if assigned(tprocdef(pd).capturedsyms) and
  2226. (
  2227. (tprocdef(pd).capturedsyms.count>1) or
  2228. (
  2229. (tprocdef(pd).capturedsyms.count=1) and
  2230. not is_self_sym(tsym(pcapturedsyminfo(tprocdef(pd).capturedsyms[0])^.sym))
  2231. )
  2232. ) then
  2233. internalerror(2021060801);
  2234. selfsym:=nil;
  2235. fpsym:=nil;
  2236. { find the framepointer parameter and an eventual self }
  2237. for i:=0 to tprocdef(pd).parast.symlist.count-1 do
  2238. begin
  2239. sym:=tsym(tprocdef(pd).parast.symlist[i]);
  2240. if sym.typ<>paravarsym then
  2241. continue;
  2242. if vo_is_parentfp in tparavarsym(sym).varoptions then
  2243. fpsym:=sym;
  2244. if vo_is_self in tparavarsym(sym).varoptions then
  2245. selfsym:=sym;
  2246. if assigned(fpsym) and assigned(selfsym) then
  2247. break;
  2248. end;
  2249. if assigned(fpsym) then
  2250. tprocdef(pd).parast.symlist.remove(fpsym);
  2251. { if we don't have a self parameter already we need to
  2252. insert a suitable one }
  2253. if not assigned(selfsym) then
  2254. begin
  2255. { replace the self symbol by the new parameter if it was
  2256. captured }
  2257. if assigned(tprocdef(pd).capturedsyms) and
  2258. (tprocdef(pd).capturedsyms.count>0) then
  2259. begin
  2260. if not assigned(tprocdef(pd).struct) then
  2261. { we can't use the captured symbol for the struct as that
  2262. might be the self of a type helper, thus we need to find
  2263. the parent procinfo that provides the Self }
  2264. tprocdef(pd).struct:=current_procinfo.get_normal_proc.procdef.struct;
  2265. if not assigned(tprocdef(pd).struct) then
  2266. internalerror(2021062204);
  2267. insert_self_and_vmt_para(pd);
  2268. mapping.oldsym:=tsym(pcapturedsyminfo(tprocdef(pd).capturedsyms[0])^.sym);
  2269. mapping.newsym:=nil;
  2270. { find the new self parameter }
  2271. for i:=0 to tprocdef(pd).parast.symlist.count-1 do
  2272. begin
  2273. sym:=tsym(tprocdef(pd).parast.symlist[i]);
  2274. if (sym.typ=paravarsym) and (vo_is_self in tparavarsym(sym).varoptions) then
  2275. begin
  2276. mapping.newsym:=sym;
  2277. break;
  2278. end;
  2279. end;
  2280. if not assigned(mapping.newsym) then
  2281. internalerror(2021062202);
  2282. { the anonymous function can only be a direct child of the
  2283. current_procinfo }
  2284. pi:=current_procinfo.get_first_nestedproc;
  2285. while assigned(pi) do
  2286. begin
  2287. if pi.procdef=pd then
  2288. break;
  2289. pi:=tprocinfo(pi.next);
  2290. end;
  2291. if not assigned(pi) then
  2292. internalerror(2021062203);
  2293. { replace all uses of the captured Self by the new Self
  2294. parameter }
  2295. foreachnodestatic(pm_preprocess,tcgprocinfo(pi).code,@replace_self_sym,@mapping);
  2296. mapping.oldsym.free;
  2297. end
  2298. else
  2299. begin
  2300. { for a nested function of a method struct is already
  2301. set }
  2302. if not assigned(tprocdef(pd).struct) then
  2303. { simply add a TObject as Self parameter }
  2304. tprocdef(pd).struct:=class_tobject;
  2305. insert_self_and_vmt_para(pd);
  2306. { there is no self, so load a nil value }
  2307. tloadnode(left).set_mp(cnilnode.create);
  2308. end;
  2309. end;
  2310. { the anonymous function no longer adheres to the nested
  2311. calling convention }
  2312. exclude(pd.procoptions,po_delphi_nested_cc);
  2313. tprocdef(pd).calcparas;
  2314. if not assigned(tloadnode(left).left) then
  2315. tloadnode(left).set_mp(load_self_node);
  2316. end
  2317. else if tprocvardef(totypedef).is_addressonly then
  2318. begin
  2319. if assigned(tprocdef(pd).capturedsyms) and (tprocdef(pd).capturedsyms.count>0) then
  2320. internalerror(2021060802);
  2321. { remove framepointer and Self parameters }
  2322. for i:=tprocdef(pd).parast.symlist.count-1 downto 0 do
  2323. begin
  2324. sym:=tsym(tprocdef(pd).parast.symlist[i]);
  2325. if (sym.typ=paravarsym) and (tparavarsym(sym).varoptions*[vo_is_parentfp,vo_is_self]<>[]) then
  2326. tprocdef(pd).parast.symlist.delete(i);
  2327. end;
  2328. { the anonymous function no longer adheres to the nested
  2329. calling convention }
  2330. exclude(pd.procoptions,po_delphi_nested_cc);
  2331. { we don't need to look through the existing nodes, cause
  2332. the parameter was never used anyway }
  2333. tprocdef(pd).calcparas;
  2334. end
  2335. else
  2336. begin
  2337. { this is a nested function pointer, so ensure that the
  2338. anonymous function is handled as such }
  2339. if assigned(tprocdef(pd).capturedsyms) and
  2340. (tprocdef(pd).capturedsyms.count>0) and
  2341. (left.nodetype=loadn) then
  2342. begin
  2343. tloadnode(left).left:=cloadparentfpnode.create(tprocdef(tloadnode(left).symtable.defowner),lpf_forload);
  2344. pi:=current_procinfo.get_first_nestedproc;
  2345. while assigned(pi) do
  2346. begin
  2347. if pi.procdef=pd then
  2348. break;
  2349. pi:=tprocinfo(pi.next);
  2350. end;
  2351. pi.set_needs_parentfp(tprocdef(tloadnode(left).symtable.defowner).parast.symtablelevel);
  2352. end;
  2353. end;
  2354. end;
  2355. resultdef:=totypedef;
  2356. end
  2357. else
  2358. begin
  2359. { only need the address of the method? this is needed
  2360. for @tobject.create. In this case there will be a loadn without
  2361. a methodpointer. }
  2362. if (left.nodetype=loadn) and
  2363. not assigned(tloadnode(left).left) and
  2364. (not(m_nested_procvars in current_settings.modeswitches) or
  2365. not is_nested_pd(tabstractprocdef(tloadnode(left).resultdef))) then
  2366. copytype:=pc_address_only
  2367. else
  2368. copytype:=pc_normal;
  2369. resultdef:=cprocvardef.getreusableprocaddr(pd,copytype);
  2370. end;
  2371. end;
  2372. function ttypeconvnode.typecheck_procvar_2_funcref : tnode;
  2373. var
  2374. capturer : tsym;
  2375. intfdef : tdef;
  2376. ld,blck,hp : tnode;
  2377. stmt : tstatementnode;
  2378. begin
  2379. result:=nil;
  2380. if not(m_tp_procvar in current_settings.modeswitches) and
  2381. is_invokable(resultdef) and
  2382. (left.nodetype=typeconvn) and
  2383. (ttypeconvnode(left).convtype=tc_proc_2_procvar) and
  2384. is_methodpointer(left.resultdef) and
  2385. (po_classmethod in tprocvardef(left.resultdef).procoptions) and
  2386. not(po_staticmethod in tprocvardef(left.resultdef).procoptions) and
  2387. (proc_to_funcref_equal(tprocdef(ttypeconvnode(left).left.resultdef),tobjectdef(resultdef))>=te_convert_l1) then
  2388. begin
  2389. hp:=left;
  2390. left:=ttypeconvnode(left).left;
  2391. if (left.nodetype=loadn) and
  2392. not assigned(tloadnode(left).left) then
  2393. tloadnode(left).set_mp(cloadvmtaddrnode.create(ctypenode.create(tdef(tloadnode(left).symtable.defowner))));
  2394. left:=ctypeconvnode.create_proc_to_procvar(left);
  2395. ttypeconvnode(left).totypedef:=resultdef;
  2396. typecheckpass(left);
  2397. ttypeconvnode(hp).left:=nil;
  2398. hp.free;
  2399. end;
  2400. intfdef:=capturer_add_procvar_or_proc(current_procinfo,left,capturer,hp);
  2401. if assigned(intfdef) then
  2402. begin
  2403. if assigned(capturer) then
  2404. ld:=cloadnode.create(capturer,capturer.owner)
  2405. else
  2406. ld:=cnilnode.create;
  2407. result:=ctypeconvnode.create_internal(
  2408. ctypeconvnode.create_internal(
  2409. ld,
  2410. intfdef),
  2411. totypedef);
  2412. if assigned(hp) then
  2413. begin
  2414. blck:=internalstatements(stmt);
  2415. addstatement(stmt,cassignmentnode.create(hp,left));
  2416. left:=nil;
  2417. addstatement(stmt,result);
  2418. result:=blck;
  2419. end;
  2420. end;
  2421. if not assigned(result) then
  2422. result:=cerrornode.create;
  2423. end;
  2424. function ttypeconvnode.typecheck_anonproc_2_funcref : tnode;
  2425. var
  2426. capturer : tsym;
  2427. intfdef : tdef;
  2428. ldnode : tnode;
  2429. begin
  2430. intfdef:=capturer_add_anonymous_proc(current_procinfo,tprocdef(left.resultdef),capturer);
  2431. if assigned(intfdef) then
  2432. begin
  2433. if assigned(capturer) then
  2434. ldnode:=cloadnode.create(capturer,capturer.owner)
  2435. else
  2436. ldnode:=cnilnode.create;
  2437. result:=ctypeconvnode.create_internal(
  2438. ctypeconvnode.create_internal(
  2439. ldnode,
  2440. intfdef),
  2441. totypedef);
  2442. end
  2443. else
  2444. result:=cerrornode.create;
  2445. end;
  2446. function ttypeconvnode.typecheck_call_helper(c : tconverttype) : tnode;
  2447. const
  2448. resultdefconvert : array[tconverttype] of pointer = (
  2449. {none} nil,
  2450. {equal} nil,
  2451. {not_possible} nil,
  2452. { string_2_string } @ttypeconvnode._typecheck_string_to_string,
  2453. { char_2_string } @ttypeconvnode._typecheck_char_to_string,
  2454. { char_2_chararray } @ttypeconvnode._typecheck_char_to_chararray,
  2455. { pchar_2_string } @ttypeconvnode._typecheck_pchar_to_string,
  2456. { cchar_2_pchar } @ttypeconvnode._typecheck_cchar_to_pchar,
  2457. { cstring_2_pchar } @ttypeconvnode._typecheck_cstring_to_pchar,
  2458. { cstring_2_int } @ttypeconvnode._typecheck_cstring_to_int,
  2459. { ansistring_2_pchar } nil,
  2460. { string_2_chararray } @ttypeconvnode._typecheck_string_to_chararray,
  2461. { chararray_2_string } @ttypeconvnode._typecheck_chararray_to_string,
  2462. { array_2_pointer } nil,
  2463. { pointer_2_array } nil,
  2464. { int_2_int } @ttypeconvnode._typecheck_int_to_int,
  2465. { int_2_bool } nil,
  2466. { bool_2_bool } nil,
  2467. { bool_2_int } nil,
  2468. { real_2_real } @ttypeconvnode._typecheck_real_to_real,
  2469. { int_2_real } @ttypeconvnode._typecheck_int_to_real,
  2470. { real_2_currency } @ttypeconvnode._typecheck_real_to_currency,
  2471. { proc_2_procvar } @ttypeconvnode._typecheck_proc_to_procvar,
  2472. { nil_2_methodprocvar } nil,
  2473. { arrayconstructor_2_set } @ttypeconvnode._typecheck_arrayconstructor_to_set,
  2474. { set_to_set } @ttypeconvnode._typecheck_set_to_set,
  2475. { cord_2_pointer } @ttypeconvnode._typecheck_cord_to_pointer,
  2476. { intf_2_string } @ttypeconvnode._typecheck_interface_to_string,
  2477. { intf_2_guid } @ttypeconvnode._typecheck_interface_to_guid,
  2478. { class_2_intf } nil,
  2479. { char_2_char } @ttypeconvnode._typecheck_char_to_char,
  2480. { dynarray_2_openarray} @ttypeconvnode._typecheck_dynarray_to_openarray,
  2481. { pwchar_2_string} @ttypeconvnode._typecheck_pwchar_to_string,
  2482. { variant_2_dynarray} @ttypeconvnode._typecheck_variant_to_dynarray,
  2483. { dynarray_2_variant} @ttypeconvnode._typecheck_dynarray_to_variant,
  2484. { variant_2_enum} @ttypeconvnode._typecheck_variant_to_enum,
  2485. { enum_2_variant} @ttypeconvnode._typecheck_enum_to_variant,
  2486. { variant_2_interface} @ttypeconvnode._typecheck_interface_to_variant,
  2487. { interface_2_variant} @ttypeconvnode._typecheck_variant_to_interface,
  2488. { array_2_dynarray} @ttypeconvnode._typecheck_array_2_dynarray,
  2489. { elem_2_openarray } @ttypeconvnode._typecheck_elem_2_openarray,
  2490. { arrayconstructor_2_dynarray } @ttypeconvnode._typecheck_arrayconstructor_to_dynarray,
  2491. { arrayconstructor_2_array } @ttypeconvnode._typecheck_arrayconstructor_to_array,
  2492. { anonproc_2_funcref } @ttypeconvnode._typecheck_anonproc_to_funcref,
  2493. { procvar_2_funcref } @ttypeconvnode._typecheck_procvar_to_funcref
  2494. );
  2495. type
  2496. tprocedureofobject = function : tnode of object;
  2497. var
  2498. r : TMethod;
  2499. begin
  2500. result:=nil;
  2501. { this is a little bit dirty but it works }
  2502. { and should be quite portable too }
  2503. r.Code:=resultdefconvert[c];
  2504. r.Data:=self;
  2505. if assigned(r.Code) then
  2506. result:=tprocedureofobject(r)();
  2507. end;
  2508. function ttypeconvnode.pass_typecheck:tnode;
  2509. var
  2510. hdef : tdef;
  2511. hp : tnode;
  2512. currprocdef : tabstractprocdef;
  2513. aprocdef : tprocdef;
  2514. eq : tequaltype;
  2515. cdoptions : tcompare_defs_options;
  2516. selfnode : tnode;
  2517. newblock: tblocknode;
  2518. newstatement: tstatementnode;
  2519. tempnode: ttempcreatenode;
  2520. begin
  2521. result:=nil;
  2522. resultdef:=totypedef;
  2523. typecheckpass(left);
  2524. if codegenerror then
  2525. exit;
  2526. { When absolute force tc_equal }
  2527. if (nf_absolute in flags) then
  2528. begin
  2529. convtype:=tc_equal;
  2530. { we need to check regability only if something is really regable }
  2531. if ((tstoreddef(left.resultdef).is_intregable) or
  2532. (tstoreddef(resultdef).is_fpuregable)) and
  2533. (
  2534. (tstoreddef(resultdef).is_intregable<>tstoreddef(left.resultdef).is_intregable) or
  2535. (tstoreddef(resultdef).is_fpuregable<>tstoreddef(left.resultdef).is_fpuregable) or
  2536. { like in pdecvar.read_absolute(): if the size changes, the
  2537. register size would also have to change (but second_nothing
  2538. does not handle this) }
  2539. (tstoreddef(resultdef).size<>tstoreddef(left.resultdef).size)) then
  2540. make_not_regable(left,[ra_addr_regable]);
  2541. exit;
  2542. end;
  2543. { tp procvar support. Skip typecasts to procvar, record or set. Those
  2544. convert on the procvar value. This is used to access the
  2545. fields of a methodpointer }
  2546. if not(nf_load_procvar in flags) and
  2547. not(resultdef.typ in [procvardef,recorddef,setdef]) and
  2548. not is_invokable(resultdef) and
  2549. { in case of interface assignments of invokables they'll be converted
  2550. to voidpointertype using an internal conversions; we must not call
  2551. the invokable in that case }
  2552. not (
  2553. (nf_internal in flags) and
  2554. is_invokable(left.resultdef)
  2555. ) then
  2556. maybe_call_procvar(left,true);
  2557. if target_specific_general_typeconv then
  2558. exit;
  2559. if convtype=tc_none then
  2560. begin
  2561. cdoptions:=[cdo_allow_variant,cdo_warn_incompatible_univ];
  2562. { overloaded operators require calls, which is not possible inside
  2563. a constant declaration }
  2564. if (block_type<>bt_const) and
  2565. not(nf_internal in flags) then
  2566. include(cdoptions,cdo_check_operator);
  2567. if nf_explicit in flags then
  2568. include(cdoptions,cdo_explicit);
  2569. if nf_internal in flags then
  2570. include(cdoptions,cdo_internal);
  2571. aprocdef:=nil;
  2572. eq:=compare_defs_ext(left.resultdef,resultdef,left.nodetype,convtype,aprocdef,cdoptions);
  2573. case eq of
  2574. te_exact,
  2575. te_equal :
  2576. begin
  2577. result := simplify(false);
  2578. if assigned(result) then
  2579. exit;
  2580. { in case of bitpacked accesses, the original type must
  2581. remain so that not too many/few bits are laoded }
  2582. if is_bitpacked_access(left) then
  2583. convtype:=tc_int_2_int;
  2584. { Only leave when there is no conversion to do.
  2585. We can still need to call a conversion routine,
  2586. like the routine to convert a stringconstnode }
  2587. if (convtype in [tc_equal,tc_not_possible]) and
  2588. { some conversions, like dynarray to pointer in Delphi
  2589. mode, must not be removed, because then we get memory
  2590. leaks due to missing temp finalization }
  2591. (not is_managed_type(left.resultdef) or
  2592. { different kinds of refcounted types may need calls
  2593. to different kinds of refcounting helpers }
  2594. (resultdef=left.resultdef)) then
  2595. begin
  2596. {$ifdef llvm}
  2597. { we still may have to insert a type conversion at the
  2598. llvm level }
  2599. if (blocktype<>bt_const) and
  2600. (left.resultdef<>resultdef) and
  2601. { if unspecialised generic -> we won't generate any code
  2602. for this, and keeping the type conversion node will
  2603. cause valid_for_assign to fail because the typecast will be from/to something of 0
  2604. bytes to/from something with a non-zero size }
  2605. not is_typeparam(left.resultdef) and
  2606. not is_typeparam(resultdef) then
  2607. result:=nil
  2608. else
  2609. {$endif llvm}
  2610. begin
  2611. left.resultdef:=resultdef;
  2612. if (nf_explicit in flags) and (left.nodetype = addrn) then
  2613. include(taddrnode(left).addrnodeflags,anf_typedaddr);
  2614. result:=left;
  2615. left:=nil;
  2616. end;
  2617. exit;
  2618. end;
  2619. end;
  2620. te_convert_l1,
  2621. te_convert_l2,
  2622. te_convert_l3,
  2623. te_convert_l4,
  2624. te_convert_l5,
  2625. te_convert_l6:
  2626. { nothing to do }
  2627. ;
  2628. te_convert_operator :
  2629. begin
  2630. include(current_procinfo.flags,pi_do_call);
  2631. addsymref(aprocdef.procsym,aprocdef);
  2632. hp:=ccallnode.create(ccallparanode.create(left,nil),Tprocsym(aprocdef.procsym),nil,nil,[],nil);
  2633. { tell explicitly which def we must use !! (PM) }
  2634. tcallnode(hp).procdefinition:=aprocdef;
  2635. left:=nil;
  2636. result:=hp;
  2637. exit;
  2638. end;
  2639. te_incompatible :
  2640. begin
  2641. { convert an array constructor to a set so that we still get
  2642. the error "set of Y incompatible to Z" instead of "array of
  2643. X incompatible to Z" }
  2644. if (resultdef.typ<>arraydef) and
  2645. is_array_constructor(left.resultdef) then
  2646. begin
  2647. arrayconstructor_to_set(left);
  2648. typecheckpass(left);
  2649. end;
  2650. { Procedures have a resultdef of voiddef and functions of their
  2651. own resultdef. They will therefore always be incompatible with
  2652. a procvar. Because isconvertable cannot check for procedures we
  2653. use an extra check for them.}
  2654. if (left.nodetype=calln) and
  2655. (tcallnode(left).required_para_count=0) and
  2656. (
  2657. (resultdef.typ=procvardef) or
  2658. is_invokable(resultdef)
  2659. ) and
  2660. (
  2661. (m_tp_procvar in current_settings.modeswitches) or
  2662. (m_mac_procvar in current_settings.modeswitches)
  2663. ) then
  2664. begin
  2665. if assigned(tcallnode(left).right) then
  2666. begin
  2667. { this is already a procvar, if it is really equal
  2668. is checked below }
  2669. convtype:=tc_equal;
  2670. hp:=tcallnode(left).right.getcopy;
  2671. currprocdef:=tabstractprocdef(hp.resultdef);
  2672. end
  2673. else
  2674. begin
  2675. if resultdef.typ=procvardef then
  2676. begin
  2677. convtype:=tc_proc_2_procvar;
  2678. currprocdef:=Tprocsym(Tcallnode(left).symtableprocentry).Find_procdef_byprocvardef(Tprocvardef(resultdef));
  2679. end
  2680. else
  2681. begin
  2682. convtype:=tc_procvar_2_funcref;
  2683. currprocdef:=tprocsym(tcallnode(left).symtableprocentry).find_procdef_byfuncrefdef(tobjectdef(resultdef));
  2684. end;
  2685. hp:=cloadnode.create_procvar(tprocsym(tcallnode(left).symtableprocentry),
  2686. tprocdef(currprocdef),tcallnode(left).symtableproc);
  2687. if (tcallnode(left).symtableprocentry.owner.symtabletype=ObjectSymtable) then
  2688. begin
  2689. selfnode:=tcallnode(left).methodpointer;
  2690. if assigned(selfnode) then
  2691. begin
  2692. { in case the nodetype is a typen, avoid the internal error
  2693. in set_mp and instead let the code error out normally }
  2694. if selfnode.nodetype<>typen then
  2695. tloadnode(hp).set_mp(selfnode.getcopy)
  2696. end
  2697. else
  2698. tloadnode(hp).set_mp(load_self_node);
  2699. end;
  2700. typecheckpass(hp);
  2701. end;
  2702. left.free;
  2703. left:=hp;
  2704. { Now check if the procedure we are going to assign to
  2705. the procvar, is compatible with the procvar's type }
  2706. if not(nf_explicit in flags) and
  2707. (
  2708. (
  2709. (resultdef.typ=procvardef) and
  2710. (proc_to_procvar_equal(currprocdef,tprocvardef(resultdef),false)=te_incompatible)
  2711. ) or (
  2712. is_invokable(resultdef) and
  2713. (proc_to_funcref_equal(currprocdef,tobjectdef(resultdef))=te_incompatible)
  2714. )
  2715. ) then
  2716. IncompatibleTypes(left.resultdef,resultdef)
  2717. else
  2718. result:=typecheck_call_helper(convtype);
  2719. exit;
  2720. end
  2721. else if maybe_global_proc_to_nested(left,resultdef) or
  2722. maybe_classmethod_to_methodprocvar(left,resultdef) then
  2723. begin
  2724. result:=left;
  2725. left:=nil;
  2726. exit;
  2727. end;
  2728. { Handle explicit type conversions }
  2729. if nf_explicit in flags then
  2730. begin
  2731. { do common tc_equal cast, except when dealing with proc -> procvar
  2732. (may have to get rid of method pointer) }
  2733. if (left.resultdef.typ<>procdef) or
  2734. (resultdef.typ<>procvardef) then
  2735. convtype:=tc_equal
  2736. else
  2737. convtype:=tc_proc_2_procvar;
  2738. { ordinal constants can be resized to 1,2,4,8 bytes }
  2739. if (left.nodetype=ordconstn) then
  2740. begin
  2741. { Insert typeconv for ordinal to the correct size first on left, after
  2742. that the other conversion can be done }
  2743. hdef:=nil;
  2744. case longint(resultdef.size) of
  2745. 1 :
  2746. hdef:=s8inttype;
  2747. 2 :
  2748. hdef:=s16inttype;
  2749. 4 :
  2750. hdef:=s32inttype;
  2751. 8 :
  2752. hdef:=s64inttype;
  2753. end;
  2754. { we need explicit, because it can also be an enum }
  2755. if assigned(hdef) then
  2756. inserttypeconv_internal(left,hdef)
  2757. else
  2758. CGMessage2(type_e_illegal_type_conversion,left.resultdef.typename,resultdef.typename);
  2759. end;
  2760. { class/interface to class/interface, with checkobject support }
  2761. if is_class_or_interface_or_objc(resultdef) and
  2762. is_class_or_interface_or_objc(left.resultdef) then
  2763. begin
  2764. { check if the types are related }
  2765. if not(nf_internal in flags) and
  2766. (not(def_is_related(tobjectdef(left.resultdef),tobjectdef(resultdef)))) and
  2767. (not(def_is_related(tobjectdef(resultdef),tobjectdef(left.resultdef)))) then
  2768. begin
  2769. { Give an error when typecasting class to interface, this is compatible
  2770. with delphi }
  2771. if is_interface(resultdef) and
  2772. not is_interface(left.resultdef) then
  2773. CGMessage2(type_e_classes_not_related,
  2774. FullTypeName(left.resultdef,resultdef),
  2775. FullTypeName(resultdef,left.resultdef))
  2776. else
  2777. CGMessage2(type_w_classes_not_related,
  2778. FullTypeName(left.resultdef,resultdef),
  2779. FullTypeName(resultdef,left.resultdef))
  2780. end;
  2781. { Add runtime check? }
  2782. if not is_objc_class_or_protocol(resultdef) and
  2783. not is_objc_class_or_protocol(left.resultdef) and
  2784. (cs_check_object in current_settings.localswitches) and
  2785. not(nf_internal in flags) then
  2786. begin
  2787. { we can translate the typeconvnode to 'as' when
  2788. typecasting to a class or interface }
  2789. { we need to make sure the result can still be
  2790. passed as a var parameter }
  2791. newblock:=internalstatements(newstatement);
  2792. if (valid_for_var(left,false)) then
  2793. begin
  2794. tempnode:=ctempcreatenode.create(voidpointertype,voidpointertype.size,tt_persistent,true);
  2795. addstatement(newstatement,tempnode);
  2796. addstatement(newstatement,cassignmentnode.create(
  2797. ctemprefnode.create(tempnode),
  2798. caddrnode.create_internal(left)));
  2799. left:=ctypeconvnode.create_internal(cderefnode.create(ctemprefnode.create(tempnode)),left.resultdef);
  2800. end
  2801. else
  2802. begin
  2803. tempnode:=ctempcreatenode.create(left.resultdef,left.resultdef.size,tt_persistent,true);
  2804. addstatement(newstatement,tempnode);
  2805. addstatement(newstatement,cassignmentnode.create(
  2806. ctemprefnode.create(tempnode),
  2807. left));
  2808. left:=ctemprefnode.create(tempnode);
  2809. end;
  2810. addstatement(newstatement,casnode.create(left.getcopy,cloadvmtaddrnode.create(ctypenode.create(resultdef))));
  2811. addstatement(newstatement,ctempdeletenode.create_normal_temp(tempnode));
  2812. addstatement(newstatement,ctypeconvnode.create_internal(left,resultdef));
  2813. left:=nil;
  2814. result:=newblock;
  2815. exit;
  2816. end;
  2817. end
  2818. else
  2819. begin
  2820. { only if the same size or formal def, and }
  2821. { don't allow type casting of constants to }
  2822. { structured types }
  2823. if not(
  2824. (left.resultdef.typ=formaldef) or
  2825. {$ifdef jvm}
  2826. { enums /are/ class instances on the JVM
  2827. platform }
  2828. (((left.resultdef.typ=enumdef) and
  2829. (resultdef.typ=objectdef)) or
  2830. ((resultdef.typ=enumdef) and
  2831. (left.resultdef.typ=objectdef))) or
  2832. {$endif}
  2833. (
  2834. is_void(left.resultdef) and
  2835. (left.nodetype=derefn)
  2836. ) or
  2837. (
  2838. not(is_open_array(left.resultdef)) and
  2839. not(is_array_constructor(left.resultdef)) and
  2840. not(is_array_of_const(left.resultdef)) and
  2841. (left.resultdef.size=resultdef.size) and
  2842. { disallow casts of const nodes }
  2843. (not is_constnode(left) or
  2844. { however, there are some exceptions }
  2845. (not(resultdef.typ in [arraydef,recorddef,setdef,stringdef,
  2846. filedef,variantdef,objectdef]) or
  2847. is_class_or_interface_or_objc(resultdef) or
  2848. { the softfloat code generates casts <const. float> to record }
  2849. (nf_internal in flags)
  2850. ))
  2851. )
  2852. ) then
  2853. CGMessage2(type_e_illegal_type_conversion,left.resultdef.typename,resultdef.typename)
  2854. else
  2855. begin
  2856. { perform target-specific explicit typecast
  2857. checks }
  2858. if target_specific_explicit_typeconv then
  2859. begin
  2860. result:=simplify(false);
  2861. exit;
  2862. end;
  2863. end;
  2864. end;
  2865. end
  2866. else
  2867. IncompatibleTypes(left.resultdef,resultdef);
  2868. end;
  2869. end;
  2870. end;
  2871. { Give hint or warning for unportable code, exceptions are
  2872. - typecasts from constants
  2873. - void }
  2874. if not(nf_internal in flags) and
  2875. (left.nodetype<>ordconstn) and
  2876. not(is_void(left.resultdef)) and
  2877. (((left.resultdef.typ=orddef) and
  2878. (resultdef.typ in [pointerdef,procvardef,classrefdef])) or
  2879. ((resultdef.typ=orddef) and
  2880. (left.resultdef.typ in [pointerdef,procvardef,classrefdef]))) then
  2881. begin
  2882. {Converting pointers to signed integers is a bad idea. Warn.}
  2883. warn_pointer_to_signed:=(resultdef.typ=orddef) and (Torddef(resultdef).ordtype in [s8bit,s16bit,s32bit,s64bit]);
  2884. { Give a warning when sizes don't match, because then info will be lost }
  2885. if left.resultdef.size=resultdef.size then
  2886. CGMessage(type_h_pointer_to_longint_conv_not_portable)
  2887. else
  2888. CGMessage(type_w_pointer_to_longint_conv_not_portable);
  2889. end;
  2890. { tc_cord_2_pointer still requires a type check, which
  2891. simplify does not do }
  2892. if (convtype<>tc_cord_2_pointer) then
  2893. begin
  2894. result := simplify(false);
  2895. if assigned(result) then
  2896. exit;
  2897. end;
  2898. { now call the resultdef helper to do constant folding }
  2899. result:=typecheck_call_helper(convtype);
  2900. end;
  2901. { some code generators for 64 bit CPUs might not support 32 bit operations, so we can
  2902. disable the following optimization in fpcdefs.inc. Currently the only CPU for which
  2903. this applies is powerpc64
  2904. }
  2905. {$ifndef CPUNO32BITOPS}
  2906. { checks whether we can safely remove typeconversions to bigger types
  2907. in case range and overflow checking are off, and in case
  2908. the result of this node tree is downcasted again to a
  2909. smaller type value afterwards,
  2910. the smaller types being allowed are described by validints, ordinal constants must fit into l..h
  2911. We do this on 64 bit CPUs as well, they benefit from it as well }
  2912. function checkremovebiginttypeconvs(n: tnode; out gotsint: boolean;validints : tordtypeset;const l,h : Tconstexprint): boolean;
  2913. var
  2914. gotminus1,
  2915. gotsigned,
  2916. gotunsigned,
  2917. gotdivmod: boolean;
  2918. { checks whether a node has an accepted resultdef, or originally
  2919. had one but was implicitly converted to s64bit }
  2920. function wasoriginallysmallerint(n: tnode): boolean;
  2921. begin
  2922. if (n.resultdef.typ<>orddef) then
  2923. exit(false);
  2924. gotsigned:=gotsigned or is_signed(n.resultdef);
  2925. gotunsigned:=gotunsigned or not(is_signed(n.resultdef));
  2926. { actually, we should only check right (denominator) nodes here, but
  2927. setting it always is a safe approximation }
  2928. if ((n.nodetype=ordconstn) and
  2929. (tordconstnode(n).value=-1)) then
  2930. gotminus1:=true;
  2931. if (torddef(n.resultdef).ordtype in validints) then
  2932. begin
  2933. if is_signed(n.resultdef) then
  2934. gotsint:=true;
  2935. exit(true);
  2936. end;
  2937. { type conv to a bigger int, we do not like to use? }
  2938. if (torddef(n.resultdef).ordtype in ([s8bit,u8bit,s16bit,u16bit,s32bit,u32bit,s64bit,u64bit]-validints)) and
  2939. { nf_explicit is also set for explicitly typecasted }
  2940. { ordconstn's }
  2941. ([nf_internal,nf_explicit]*n.flags=[]) and
  2942. { either a typeconversion node coming from a smaller type }
  2943. (((n.nodetype=typeconvn) and
  2944. (ttypeconvnode(n).left.resultdef.typ=orddef) and
  2945. (torddef(ttypeconvnode(n).left.resultdef).ordtype in validints)) or
  2946. { or an ordconstnode which has a smaller type}
  2947. ((n.nodetype=ordconstn) and
  2948. (tordconstnode(n).value>=l) and
  2949. (tordconstnode(n).value<=h))) then
  2950. begin
  2951. if ((n.nodetype=typeconvn) and
  2952. is_signed(ttypeconvnode(n).left.resultdef)) or
  2953. ((n.nodetype=ordconstn) and
  2954. (tordconstnode(n).value<0)) then
  2955. begin
  2956. gotsint:=true;
  2957. gotsigned:=true;
  2958. end
  2959. else
  2960. gotunsigned:=true;
  2961. exit(true);
  2962. end;
  2963. result:=false;
  2964. end;
  2965. function docheckremoveinttypeconvs(n: tnode): boolean;
  2966. begin
  2967. if wasoriginallysmallerint(n) then
  2968. exit(true);
  2969. case n.nodetype of
  2970. subn,orn,xorn:
  2971. begin
  2972. { the result could become negative in this case }
  2973. if n.nodetype=subn then
  2974. gotsint:=true;
  2975. result:=
  2976. docheckremoveinttypeconvs(tbinarynode(n).left) and
  2977. docheckremoveinttypeconvs(tbinarynode(n).right);
  2978. end;
  2979. unaryminusn:
  2980. begin
  2981. gotsint:=true;
  2982. result:=docheckremoveinttypeconvs(tunarynode(n).left);
  2983. end;
  2984. shrn:
  2985. begin
  2986. result:=wasoriginallysmallerint(tbinarynode(n).left) and
  2987. docheckremoveinttypeconvs(tbinarynode(n).right);
  2988. end;
  2989. notn:
  2990. result:=docheckremoveinttypeconvs(tunarynode(n).left);
  2991. addn,muln,divn,modn,andn,shln:
  2992. begin
  2993. if n.nodetype in [divn,modn] then
  2994. gotdivmod:=true;
  2995. result:=
  2996. (docheckremoveinttypeconvs(tbinarynode(n).left) and
  2997. docheckremoveinttypeconvs(tbinarynode(n).right) and
  2998. (not(n.nodetype in [modn,divn]) or (not(gotminus1)))
  2999. ) or
  3000. (
  3001. (n.nodetype=andn) and
  3002. (
  3003. { Right node is more likely to be a constant, so check
  3004. this one first }
  3005. wasoriginallysmallerint(tbinarynode(n).right) or
  3006. wasoriginallysmallerint(tbinarynode(n).left)
  3007. )
  3008. );
  3009. end;
  3010. else
  3011. result:=false;
  3012. end;
  3013. end;
  3014. begin { checkremove64bittypeconvs }
  3015. gotdivmod:=false;
  3016. gotsint:=false;
  3017. gotminus1:=false;
  3018. gotsigned:=false;
  3019. gotunsigned:=false;
  3020. result:=
  3021. docheckremoveinttypeconvs(n) and
  3022. (not(gotdivmod) or (gotsigned xor gotunsigned));
  3023. end;
  3024. { remove int type conversions and set the result to the given type }
  3025. procedure doremoveinttypeconvs(level : dword;var n: tnode; todef: tdef; forceunsigned: boolean; signedtype,unsignedtype : tdef);
  3026. var
  3027. newblock: tblocknode;
  3028. newstatements: tstatementnode;
  3029. originaldivtree: tnode;
  3030. tempnode: ttempcreatenode;
  3031. begin
  3032. { we may not recurse into shr nodes:
  3033. dword1:=dword1+((dword2+dword3) shr 2);
  3034. while we can remove an extension on the outermost addition, we cannot
  3035. remove it from the shr
  3036. }
  3037. { Don't downsize into a division operation either, as the numerator can
  3038. be much larger than the result and non-linear properties prevent
  3039. accurate truncation; fixes #39646 [Kit] }
  3040. if (n.nodetype in [shrn,divn,modn]) and (level<>0) then
  3041. begin
  3042. inserttypeconv_internal(n,todef);
  3043. exit;
  3044. end;
  3045. case n.nodetype of
  3046. subn,addn,muln,divn,modn,xorn,andn,orn,shln,shrn:
  3047. begin
  3048. exclude(n.flags,nf_internal);
  3049. if not forceunsigned and
  3050. is_signed(n.resultdef) then
  3051. begin
  3052. originaldivtree:=nil;
  3053. if n.nodetype in [divn,modn] then
  3054. originaldivtree:=n.getcopy;
  3055. doremoveinttypeconvs(level+1,tbinarynode(n).left,signedtype,false,signedtype,unsignedtype);
  3056. doremoveinttypeconvs(level+1,tbinarynode(n).right,signedtype,false,signedtype,unsignedtype);
  3057. n.resultdef:=signedtype;
  3058. if n.nodetype in [divn,modn] then
  3059. begin
  3060. newblock:=internalstatements(newstatements);
  3061. tempnode:=ctempcreatenode.create(n.resultdef,n.resultdef.size,tt_persistent,true);
  3062. addstatement(newstatements,tempnode);
  3063. addstatement(newstatements,cifnode.create_internal(
  3064. caddnode.create_internal(equaln,tbinarynode(n).right.getcopy,cordconstnode.create(-1,n.resultdef,false)),
  3065. cassignmentnode.create_internal(
  3066. ctemprefnode.create(tempnode),
  3067. cmoddivnode.create(n.nodetype,tbinarynode(originaldivtree).left.getcopy,cordconstnode.create(-1,tbinarynode(originaldivtree).right.resultdef,false))
  3068. ),
  3069. cassignmentnode.create_internal(
  3070. ctemprefnode.create(tempnode),n
  3071. )
  3072. )
  3073. );
  3074. addstatement(newstatements,ctempdeletenode.create_normal_temp(tempnode));
  3075. addstatement(newstatements,ctemprefnode.create(tempnode));
  3076. n:=newblock;
  3077. do_typecheckpass(n);
  3078. originaldivtree.free;
  3079. end;
  3080. end
  3081. else
  3082. begin
  3083. doremoveinttypeconvs(level+1,tbinarynode(n).left,unsignedtype,forceunsigned,signedtype,unsignedtype);
  3084. doremoveinttypeconvs(level+1,tbinarynode(n).right,unsignedtype,forceunsigned,signedtype,unsignedtype);
  3085. n.resultdef:=unsignedtype;
  3086. end;
  3087. //if ((n.nodetype=andn) and (tbinarynode(n).left.nodetype=ordconstn) and
  3088. // ((tordconstnode(tbinarynode(n).left).value and $7fffffff)=tordconstnode(tbinarynode(n).left).value)
  3089. // ) then
  3090. // inserttypeconv_internal(tbinarynode(n).right,n.resultdef)
  3091. //else if (n.nodetype=andn) and (tbinarynode(n).right.nodetype=ordconstn) and
  3092. // ((tordconstnode(tbinarynode(n).right).value and $7fffffff)=tordconstnode(tbinarynode(n).right).value) then
  3093. // inserttypeconv_internal(tbinarynode(n).left,n.resultdef);
  3094. end;
  3095. unaryminusn,notn:
  3096. begin
  3097. exclude(n.flags,nf_internal);
  3098. if not forceunsigned and
  3099. is_signed(n.resultdef) then
  3100. begin
  3101. doremoveinttypeconvs(level+1,tunarynode(n).left,signedtype,false,signedtype,unsignedtype);
  3102. n.resultdef:=signedtype;
  3103. end
  3104. else
  3105. begin
  3106. doremoveinttypeconvs(level+1,tunarynode(n).left,unsignedtype,forceunsigned,signedtype,unsignedtype);
  3107. n.resultdef:=unsignedtype;
  3108. end;
  3109. end;
  3110. typeconvn:
  3111. begin
  3112. ttypeconvnode(n).totypedef:=todef;
  3113. { may change the type conversion, e.g. if the old conversion was
  3114. from 64 bit to a 64 bit, and now becomes 64 bit to 32 bit }
  3115. n.resultdef:=nil;
  3116. ttypeconvnode(n).convtype:=tc_none;
  3117. typecheckpass(n);
  3118. end;
  3119. else
  3120. inserttypeconv_internal(n,todef);
  3121. end;
  3122. end;
  3123. {$endif not CPUNO32BITOPS}
  3124. procedure swap_const_value (var val : TConstExprInt; size : longint);
  3125. begin
  3126. case size of
  3127. 1 : {do nothing };
  3128. 2 : if val.signed then
  3129. val.svalue:=swapendian(smallint(val.svalue))
  3130. else
  3131. val.uvalue:=swapendian(word(val.uvalue));
  3132. 4 : if val.signed then
  3133. val.svalue:=swapendian(longint(val.svalue))
  3134. else
  3135. val.uvalue:=swapendian(qword(val.uvalue));
  3136. 8 : if val.signed then
  3137. val.svalue:=swapendian(int64(val.svalue))
  3138. else
  3139. val.uvalue:=swapendian(qword(val.uvalue));
  3140. else
  3141. internalerror(2014111201);
  3142. end;
  3143. end;
  3144. function ttypeconvnode.simplify(forinline : boolean): tnode;
  3145. var
  3146. hp: tnode;
  3147. v: Tconstexprint;
  3148. {$ifndef CPUNO32BITOPS}
  3149. foundsint: boolean;
  3150. {$endif not CPUNO32BITOPS}
  3151. begin
  3152. result := nil;
  3153. { Constant folding and other node transitions to
  3154. remove the typeconv node }
  3155. case left.nodetype of
  3156. stringconstn :
  3157. if (resultdef.typ=stringdef) and
  3158. ((convtype=tc_equal) or
  3159. ((convtype=tc_string_2_string) and
  3160. (
  3161. ((not is_widechararray(left.resultdef) and
  3162. not is_wide_or_unicode_string(left.resultdef)) or
  3163. (tstringdef(resultdef).stringtype in [st_widestring,st_unicodestring,st_ansistring])
  3164. )
  3165. )
  3166. )
  3167. ) then
  3168. begin
  3169. { output string consts in local ansistring encoding }
  3170. if is_ansistring(resultdef) and
  3171. { do not mess with the result type for internally created nodes }
  3172. not(nf_internal in flags) and
  3173. ((tstringdef(resultdef).encoding=0) or (tstringdef(resultdef).encoding=globals.CP_NONE)) then
  3174. tstringconstnode(left).changestringtype(getansistringdef)
  3175. else
  3176. tstringconstnode(left).changestringtype(resultdef);
  3177. result:=left;
  3178. left:=nil;
  3179. exit;
  3180. end
  3181. else if
  3182. (convtype<>tc_cstring_2_pchar) and
  3183. is_dynamicstring(left.resultdef) and
  3184. (tstringconstnode(left).len=0) and
  3185. (resultdef.typ=pointerdef) and
  3186. cstringconstnode.emptydynstrnil then
  3187. begin
  3188. result:=cnilnode.create;
  3189. exit;
  3190. end;
  3191. realconstn :
  3192. begin
  3193. if (convtype = tc_real_2_currency) then
  3194. result := typecheck_real_to_currency
  3195. else if (convtype = tc_real_2_real) then
  3196. result := typecheck_real_to_real
  3197. else
  3198. exit;
  3199. if not(assigned(result)) then
  3200. begin
  3201. result := left;
  3202. left := nil;
  3203. end;
  3204. if (result.nodetype = realconstn) then
  3205. begin
  3206. hp:=result;
  3207. result:=crealconstnode.create(trealconstnode(hp).value_real,resultdef);
  3208. if nf_is_currency in hp.flags then
  3209. include(result.flags,nf_is_currency);
  3210. if ([nf_explicit,nf_internal] * flags <> []) then
  3211. include(result.flags, nf_explicit);
  3212. hp.free;
  3213. end;
  3214. end;
  3215. niln :
  3216. begin
  3217. { nil to ordinal node }
  3218. if (resultdef.typ=orddef) then
  3219. begin
  3220. hp:=cordconstnode.create(0,resultdef,true);
  3221. if ([nf_explicit,nf_internal] * flags <> []) then
  3222. include(hp.flags, nf_explicit);
  3223. result:=hp;
  3224. exit;
  3225. end
  3226. else
  3227. { fold nil to any pointer type }
  3228. if (resultdef.typ=pointerdef) then
  3229. begin
  3230. hp:=cnilnode.create;
  3231. hp.resultdef:=resultdef;
  3232. if ([nf_explicit,nf_internal] * flags <> []) then
  3233. include(hp.flags, nf_explicit);
  3234. result:=hp;
  3235. exit;
  3236. end
  3237. else
  3238. { remove typeconv after niln, but not when the result is a
  3239. methodpointer. The typeconv of the methodpointer will then
  3240. take care of updateing size of niln to OS_64 }
  3241. if not((resultdef.typ=procvardef) and
  3242. not(tprocvardef(resultdef).is_addressonly)) and
  3243. { converting (dynamic array) nil to a an open array is not allowed }
  3244. not is_open_array(resultdef) then
  3245. begin
  3246. left.resultdef:=resultdef;
  3247. if ([nf_explicit,nf_internal] * flags <> []) then
  3248. include(left.flags, nf_explicit);
  3249. result:=left;
  3250. left:=nil;
  3251. exit;
  3252. end;
  3253. end;
  3254. ordconstn :
  3255. begin
  3256. { ordinal contants can be directly converted }
  3257. { but not char to char because it is a widechar to char or via versa }
  3258. { which needs extra code to do the code page transistion }
  3259. { constant ordinal to pointer }
  3260. if (resultdef.typ=pointerdef) and
  3261. (convtype<>tc_cchar_2_pchar) then
  3262. begin
  3263. if (target_info.system in systems_managed_vm) and
  3264. (tordconstnode(left).value<>0) then
  3265. message(parser_e_feature_unsupported_for_vm);
  3266. hp:=cpointerconstnode.create(TConstPtrUInt(tordconstnode(left).value.uvalue),resultdef);
  3267. if ([nf_explicit,nf_internal] * flags <> []) then
  3268. include(hp.flags, nf_explicit);
  3269. result:=hp;
  3270. exit;
  3271. end
  3272. else if is_ordinal(resultdef) and
  3273. not(convtype=tc_char_2_char) then
  3274. begin
  3275. { replace the resultdef and recheck the range }
  3276. if ([nf_explicit,nf_absolute, nf_internal] * flags <> []) then
  3277. include(left.flags, nf_explicit)
  3278. else
  3279. { no longer an ordconst with an explicit typecast }
  3280. exclude(left.flags, nf_explicit);
  3281. { when converting from one boolean type to another, force }
  3282. { booleans to 0/1, and byte/word/long/qwordbool to 0/-1 }
  3283. { (Delphi-compatibile) }
  3284. if is_boolean(left.resultdef) and
  3285. is_boolean(resultdef) and
  3286. (is_cbool(left.resultdef) or
  3287. is_cbool(resultdef)) then
  3288. begin
  3289. if is_pasbool(resultdef) then
  3290. tordconstnode(left).value:=ord(tordconstnode(left).value<>0)
  3291. else
  3292. tordconstnode(left).value:=-ord(tordconstnode(left).value<>0);
  3293. end
  3294. else
  3295. begin
  3296. { for constant values on absolute variables, swapping is required }
  3297. if (target_info.endian = endian_big) and (nf_absolute in flags) then
  3298. swap_const_value(tordconstnode(left).value,tordconstnode(left).resultdef.size);
  3299. if not(nf_generic_para in flags) then
  3300. adaptrange(
  3301. resultdef,tordconstnode(left).value,
  3302. { when evaluating an explicit typecast during inlining, don't warn about
  3303. lost bits; only warn if someone literally typed e.g. byte($1ff) }
  3304. (([nf_internal,nf_absolute]*flags)<>[]) or (forinline and (nf_explicit in flags)),
  3305. nf_explicit in flags,
  3306. cs_check_range in localswitches);
  3307. { swap value back, but according to new type }
  3308. if (target_info.endian = endian_big) and (nf_absolute in flags) then
  3309. swap_const_value(tordconstnode(left).value,resultdef.size);
  3310. { cut off the new value? }
  3311. if resultdef.size<left.resultdef.size then
  3312. case resultdef.size of
  3313. 1:
  3314. if is_signed(resultdef) then
  3315. tordconstnode(left).value:=tordconstnode(left).value and shortint($ff)
  3316. else
  3317. tordconstnode(left).value:=tordconstnode(left).value and byte($ff);
  3318. 2:
  3319. if is_signed(resultdef) then
  3320. tordconstnode(left).value:=tordconstnode(left).value and smallint($ffff)
  3321. else
  3322. tordconstnode(left).value:=tordconstnode(left).value and word($ffff);
  3323. 4:
  3324. if is_signed(resultdef) then
  3325. tordconstnode(left).value:=tordconstnode(left).value and longint($ffffffff)
  3326. else
  3327. tordconstnode(left).value:=tordconstnode(left).value and dword($ffffffff);
  3328. end;
  3329. end;
  3330. left.resultdef:=resultdef;
  3331. tordconstnode(left).typedef:=resultdef;
  3332. if is_signed(resultdef) then
  3333. tordconstnode(left).value.signed:=true
  3334. else
  3335. tordconstnode(left).value.signed:=false;
  3336. result:=left;
  3337. left:=nil;
  3338. exit;
  3339. end
  3340. else if (convtype=tc_int_2_int) and
  3341. is_currency(resultdef) then
  3342. begin
  3343. v:=tordconstnode(left).value;
  3344. if not(nf_internal in flags) and not(is_currency(left.resultdef)) then
  3345. v:=v*10000;
  3346. result:=cordconstnode.create(v,resultdef,false);
  3347. exit;
  3348. end;
  3349. end;
  3350. pointerconstn :
  3351. begin
  3352. { pointerconstn to any pointer is folded too }
  3353. if (resultdef.typ=pointerdef) then
  3354. begin
  3355. left.resultdef:=resultdef;
  3356. if ([nf_explicit,nf_internal] * flags <> []) then
  3357. include(left.flags, nf_explicit)
  3358. else
  3359. { no longer an ordconst with an explicit typecast }
  3360. exclude(left.flags, nf_explicit);
  3361. result:=left;
  3362. left:=nil;
  3363. exit;
  3364. end
  3365. { constant pointer to ordinal }
  3366. else if is_ordinal(resultdef) then
  3367. begin
  3368. hp:=cordconstnode.create(TConstExprInt(tpointerconstnode(left).value),
  3369. resultdef,not(nf_explicit in flags));
  3370. if ([nf_explicit,nf_internal] * flags <> []) then
  3371. include(hp.flags, nf_explicit);
  3372. result:=hp;
  3373. exit;
  3374. end;
  3375. end;
  3376. else
  3377. ;
  3378. end;
  3379. {$ifndef CPUNO32BITOPS}
  3380. { must be done before code below, because we need the
  3381. typeconversions for ordconstn's as well }
  3382. case convtype of
  3383. tc_bool_2_int,
  3384. tc_int_2_bool,
  3385. tc_int_2_int:
  3386. begin
  3387. if (localswitches * [cs_check_range,cs_check_overflow] = []) and
  3388. (resultdef.typ in [pointerdef,orddef,enumdef]) then
  3389. begin
  3390. { avoid unnecessary widening of intermediary calculations
  3391. to 64 bit }
  3392. if (resultdef.size <= 4) and
  3393. is_64bitint(left.resultdef) and
  3394. (left.nodetype in [subn,addn,muln,divn,modn,xorn,andn,orn,notn,unaryminusn,shln,shrn]) and
  3395. checkremovebiginttypeconvs(left,foundsint,[s8bit,u8bit,s16bit,u16bit,s32bit,u32bit],int64(low(longint)),high(cardinal)) then
  3396. doremoveinttypeconvs(0,left,generrordef,not foundsint,s32inttype,u32inttype);
  3397. {$if defined(cpu16bitalu)}
  3398. if (resultdef.size <= 2) and
  3399. (is_32bitint(left.resultdef) or is_64bitint(left.resultdef)) and
  3400. (left.nodetype in [subn,addn,muln,divn,modn,xorn,andn,orn,notn,unaryminusn,shln,shrn]) and
  3401. checkremovebiginttypeconvs(left,foundsint,[s8bit,u8bit,s16bit,u16bit],int64(low(smallint)),high(word)) then
  3402. doremoveinttypeconvs(0,left,generrordef,not foundsint,s16inttype,u16inttype);
  3403. {$endif defined(cpu16bitalu)}
  3404. {$if defined(cpu8bitalu)}
  3405. if (resultdef.size<left.resultdef.size) and
  3406. is_integer(left.resultdef) and
  3407. (left.nodetype in [subn,addn,muln,divn,modn,xorn,andn,orn,notn,unaryminusn,shln,shrn]) and
  3408. checkremovebiginttypeconvs(left,foundsint,[s8bit,u8bit],int64(low(shortint)),high(byte)) then
  3409. doremoveinttypeconvs(0,left,generrordef,not foundsint,s8inttype,u8inttype);
  3410. {$endif defined(cpu8bitalu)}
  3411. { the above simplification may have left a redundant equal
  3412. typeconv (e.g. int32 to int32). If that's the case, we remove it }
  3413. if equal_defs(left.resultdef,resultdef) then
  3414. begin
  3415. result:=left;
  3416. left:=nil;
  3417. exit;
  3418. end;
  3419. if (convtype=tc_int_2_int) and (left.nodetype=typeconvn) and (ttypeconvnode(left).convtype=tc_bool_2_int) then
  3420. begin
  3421. ttypeconvnode(left).totypedef:=resultdef;
  3422. ttypeconvnode(left).resultdef:=resultdef;
  3423. result:=left;
  3424. left:=nil;
  3425. exit;
  3426. end;
  3427. end;
  3428. end;
  3429. else
  3430. ;
  3431. end;
  3432. {$endif not CPUNO32BITOPS}
  3433. end;
  3434. procedure Ttypeconvnode.mark_write;
  3435. begin
  3436. left.mark_write;
  3437. end;
  3438. function ttypeconvnode.first_cord_to_pointer : tnode;
  3439. begin
  3440. result:=nil;
  3441. internalerror(200104043);
  3442. end;
  3443. function ttypeconvnode.first_int_to_int : tnode;
  3444. begin
  3445. first_int_to_int:=nil;
  3446. expectloc:=left.expectloc;
  3447. if not is_void(left.resultdef) then
  3448. begin
  3449. if (left.expectloc<>LOC_REGISTER) and
  3450. ((resultdef.size>left.resultdef.size) or
  3451. (left.expectloc in [LOC_SUBSETREF,LOC_CSUBSETREF,LOC_SUBSETREG,LOC_CSUBSETREG])) then
  3452. expectloc:=LOC_REGISTER
  3453. else
  3454. if (left.expectloc=LOC_CREGISTER) and
  3455. (resultdef.size<left.resultdef.size) then
  3456. expectloc:=LOC_REGISTER;
  3457. end;
  3458. end;
  3459. function ttypeconvnode.first_cstring_to_pchar : tnode;
  3460. begin
  3461. result:=nil;
  3462. expectloc:=LOC_REGISTER;
  3463. end;
  3464. function ttypeconvnode.first_cstring_to_int : tnode;
  3465. begin
  3466. result:=nil;
  3467. internalerror(200510014);
  3468. end;
  3469. function ttypeconvnode.first_string_to_chararray : tnode;
  3470. begin
  3471. first_string_to_chararray:=nil;
  3472. expectloc:=left.expectloc;
  3473. end;
  3474. function ttypeconvnode.first_char_to_string : tnode;
  3475. begin
  3476. first_char_to_string:=nil;
  3477. if tstringdef(resultdef).stringtype=st_shortstring then
  3478. inc(current_procinfo.estimatedtempsize,256);
  3479. expectloc:=LOC_REFERENCE;
  3480. end;
  3481. function ttypeconvnode.first_char_to_chararray : tnode;
  3482. begin
  3483. if resultdef.size <> 1 then
  3484. begin
  3485. { convert first to string, then to chararray }
  3486. inserttypeconv(left,cshortstringtype);
  3487. inserttypeconv(left,resultdef);
  3488. result:=left;
  3489. left := nil;
  3490. exit;
  3491. end;
  3492. result := nil;
  3493. end;
  3494. function ttypeconvnode.first_nothing : tnode;
  3495. begin
  3496. first_nothing:=nil;
  3497. end;
  3498. function ttypeconvnode.first_array_to_pointer : tnode;
  3499. begin
  3500. first_array_to_pointer:=nil;
  3501. make_not_regable(left,[ra_addr_regable]);
  3502. expectloc:=LOC_REGISTER;
  3503. end;
  3504. function ttypeconvnode.first_int_to_real: tnode;
  3505. var
  3506. fname: string[32];
  3507. begin
  3508. if target_info.system in systems_wince then
  3509. begin
  3510. { converting a 64bit integer to a float requires a helper }
  3511. if is_64bitint(left.resultdef) or
  3512. is_currency(left.resultdef) then
  3513. begin
  3514. { hack to avoid double division by 10000, as it's
  3515. already done by typecheckpass.resultdef_int_to_real }
  3516. if is_currency(left.resultdef) then
  3517. left.resultdef := s64inttype;
  3518. if is_signed(left.resultdef) then
  3519. fname:='i64to'
  3520. else
  3521. fname:='ui64to';
  3522. end
  3523. else
  3524. { other integers are supposed to be 32 bit }
  3525. begin
  3526. if is_signed(left.resultdef) then
  3527. fname:='ito'
  3528. else
  3529. fname:='uto';
  3530. firstpass(left);
  3531. end;
  3532. if tfloatdef(resultdef).floattype=s64real then
  3533. fname:=fname+'d'
  3534. else
  3535. fname:=fname+'s';
  3536. result:=ccallnode.createintern(fname,ccallparanode.create(
  3537. left,nil));
  3538. left:=nil;
  3539. firstpass(result);
  3540. exit;
  3541. end
  3542. else
  3543. begin
  3544. { converting a 64bit integer to a float requires a helper }
  3545. if is_64bitint(left.resultdef) or
  3546. is_currency(left.resultdef) then
  3547. begin
  3548. { hack to avoid double division by 10000, as it's
  3549. already done by typecheckpass.resultdef_int_to_real }
  3550. if is_currency(left.resultdef) then
  3551. left.resultdef := s64inttype;
  3552. if is_signed(left.resultdef) then
  3553. fname:='int64_to_'
  3554. else
  3555. { we can't do better currently }
  3556. fname:='qword_to_';
  3557. end
  3558. else
  3559. { other integers are supposed to be 32 bit }
  3560. begin
  3561. if is_signed(left.resultdef) then
  3562. fname:='int32_to_'
  3563. else
  3564. fname:='int64_to_';
  3565. firstpass(left);
  3566. end;
  3567. if tfloatdef(resultdef).floattype=s64real then
  3568. fname:=fname+'float64'
  3569. else
  3570. fname:=fname+'float32';
  3571. result:=ctypeconvnode.create_internal(ccallnode.createintern(fname,ccallparanode.create(
  3572. left,nil)),resultdef);
  3573. left:=nil;
  3574. firstpass(result);
  3575. exit;
  3576. end;
  3577. end;
  3578. function ttypeconvnode.first_real_to_real : tnode;
  3579. begin
  3580. {$ifdef cpufpemu}
  3581. if cs_fp_emulation in current_settings.moduleswitches then
  3582. begin
  3583. if target_info.system in systems_wince then
  3584. begin
  3585. case tfloatdef(left.resultdef).floattype of
  3586. s32real:
  3587. case tfloatdef(resultdef).floattype of
  3588. s64real:
  3589. result:=ccallnode.createintern('stod',ccallparanode.create(left,nil));
  3590. s32real:
  3591. begin
  3592. result:=left;
  3593. left:=nil;
  3594. end;
  3595. else
  3596. internalerror(2005082704);
  3597. end;
  3598. s64real:
  3599. case tfloatdef(resultdef).floattype of
  3600. s32real:
  3601. result:=ccallnode.createintern('dtos',ccallparanode.create(left,nil));
  3602. s64real:
  3603. begin
  3604. result:=left;
  3605. left:=nil;
  3606. end;
  3607. else
  3608. internalerror(2005082703);
  3609. end;
  3610. else
  3611. internalerror(2005082702);
  3612. end;
  3613. left:=nil;
  3614. firstpass(result);
  3615. exit;
  3616. end
  3617. else
  3618. begin
  3619. case tfloatdef(left.resultdef).floattype of
  3620. s32real:
  3621. case tfloatdef(resultdef).floattype of
  3622. s64real:
  3623. result:=ctypeconvnode.create_explicit(ccallnode.createintern('float32_to_float64',ccallparanode.create(
  3624. ctypeconvnode.create_internal(left,search_system_type('FLOAT32REC').typedef),nil)),resultdef);
  3625. s32real:
  3626. begin
  3627. result:=left;
  3628. left:=nil;
  3629. end;
  3630. else
  3631. internalerror(200610151);
  3632. end;
  3633. s64real:
  3634. case tfloatdef(resultdef).floattype of
  3635. s32real:
  3636. result:=ctypeconvnode.create_explicit(ccallnode.createintern('float64_to_float32',ccallparanode.create(
  3637. ctypeconvnode.create_internal(left,search_system_type('FLOAT64').typedef),nil)),resultdef);
  3638. s64real:
  3639. begin
  3640. result:=left;
  3641. left:=nil;
  3642. end;
  3643. else
  3644. internalerror(200610152);
  3645. end;
  3646. else
  3647. internalerror(200610153);
  3648. end;
  3649. left:=nil;
  3650. firstpass(result);
  3651. exit;
  3652. end;
  3653. end
  3654. else
  3655. {$endif cpufpemu}
  3656. begin
  3657. first_real_to_real:=nil;
  3658. if not use_vectorfpu(resultdef) then
  3659. expectloc:=LOC_FPUREGISTER
  3660. else
  3661. expectloc:=LOC_MMREGISTER;
  3662. end;
  3663. end;
  3664. function ttypeconvnode.first_pointer_to_array : tnode;
  3665. begin
  3666. first_pointer_to_array:=nil;
  3667. expectloc:=LOC_REFERENCE;
  3668. end;
  3669. function ttypeconvnode.first_cchar_to_pchar : tnode;
  3670. begin
  3671. first_cchar_to_pchar:=nil;
  3672. internalerror(200104021);
  3673. end;
  3674. function ttypeconvnode.first_bool_to_int : tnode;
  3675. begin
  3676. first_bool_to_int:=nil;
  3677. { byte(boolean) or word(wordbool) or longint(longbool) must
  3678. be accepted for var parameters }
  3679. if (nf_explicit in flags) and
  3680. (left.resultdef.size=resultdef.size) and
  3681. (left.expectloc in [LOC_REFERENCE,LOC_CREFERENCE,LOC_CREGISTER]) then
  3682. begin
  3683. expectloc:=left.expectloc;
  3684. exit;
  3685. end;
  3686. expectloc:=LOC_REGISTER;
  3687. end;
  3688. function ttypeconvnode.first_int_to_bool : tnode;
  3689. begin
  3690. first_int_to_bool:=nil;
  3691. { byte(boolean) or word(wordbool) or longint(longbool) must
  3692. be accepted for var parameters }
  3693. if (nf_explicit in flags) and
  3694. (left.resultdef.size=resultdef.size) and
  3695. (left.expectloc in [LOC_REFERENCE,LOC_CREFERENCE,LOC_CREGISTER]) then
  3696. begin
  3697. {$ifdef xtensa}
  3698. expectloc:=LOC_REGISTER;
  3699. {$else xtensa}
  3700. expectloc:=left.expectloc;
  3701. {$endif xtensa}
  3702. exit;
  3703. end;
  3704. { when converting 64bit int to C-ctyle boolean, first convert to an int32 and then }
  3705. { convert to a boolean (only necessary for 32bit processors) }
  3706. { note: not if left is already a bool (qwordbool that is true, even if
  3707. only because the highest bit is set, must remain true if it is
  3708. --implicitly, unlike integers-- converted to another type of bool),
  3709. Left can already be a bool because this routine can also be called
  3710. from first_bool_to_bool }
  3711. if not is_boolean(left.resultdef) and
  3712. (left.resultdef.size > sizeof(aint)) and
  3713. (left.resultdef.size<>resultdef.size)
  3714. and is_cbool(resultdef) then
  3715. begin
  3716. left:=ctypeconvnode.create_internal(left,s32inttype);
  3717. firstpass(left);
  3718. exit;
  3719. end;
  3720. expectloc:=LOC_REGISTER;
  3721. end;
  3722. function ttypeconvnode.first_bool_to_bool : tnode;
  3723. begin
  3724. first_bool_to_bool:=nil;
  3725. if (left.expectloc in [LOC_FLAGS,LOC_JUMP]) and
  3726. not is_cbool(resultdef) then
  3727. expectloc := left.expectloc
  3728. { the following cases use the code generation for bool_to_int/
  3729. int_to_bool -> also set their expectlocs }
  3730. else if (resultdef.size=left.resultdef.size) and
  3731. (is_cbool(resultdef)=is_cbool(left.resultdef)) then
  3732. result:=first_bool_to_int
  3733. else
  3734. result:=first_int_to_bool
  3735. end;
  3736. function ttypeconvnode.first_char_to_char : tnode;
  3737. var
  3738. fname: string[18];
  3739. begin
  3740. if (torddef(resultdef).ordtype=uchar) and
  3741. (torddef(left.resultdef).ordtype=uwidechar) then
  3742. fname := 'fpc_uchar_to_char'
  3743. else if (torddef(resultdef).ordtype=uwidechar) and
  3744. (torddef(left.resultdef).ordtype=uchar) then
  3745. fname := 'fpc_char_to_uchar'
  3746. else
  3747. internalerror(2007081201);
  3748. result := ccallnode.createintern(fname,ccallparanode.create(left,nil));
  3749. left:=nil;
  3750. firstpass(result);
  3751. end;
  3752. function ttypeconvnode.first_proc_to_procvar : tnode;
  3753. begin
  3754. first_proc_to_procvar:=nil;
  3755. { if we take the address of a nested function, the current function/
  3756. procedure needs a stack frame since it's required to construct
  3757. the nested procvar }
  3758. if is_nested_pd(tprocvardef(resultdef)) and
  3759. (
  3760. not (po_anonymous in tprocdef(left.resultdef).procoptions) or
  3761. (po_delphi_nested_cc in tprocvardef(resultdef).procoptions)
  3762. ) then
  3763. include(current_procinfo.flags,pi_needs_stackframe);
  3764. if tabstractprocdef(resultdef).is_addressonly then
  3765. expectloc:=LOC_REGISTER
  3766. else
  3767. expectloc:=left.expectloc;
  3768. end;
  3769. function ttypeconvnode.first_nil_to_methodprocvar : tnode;
  3770. begin
  3771. first_nil_to_methodprocvar:=nil;
  3772. expectloc:=LOC_REGISTER;
  3773. end;
  3774. function ttypeconvnode.first_set_to_set : tnode;
  3775. var
  3776. newstatement : tstatementnode;
  3777. temp : ttempcreatenode;
  3778. begin
  3779. { in theory, we should do range checking here,
  3780. but Delphi doesn't do it either (FK) }
  3781. if left.nodetype=setconstn then
  3782. begin
  3783. left.resultdef:=resultdef;
  3784. result:=left;
  3785. left:=nil;
  3786. end
  3787. { equal sets for the code generator? }
  3788. else if (left.resultdef.size=resultdef.size) and
  3789. (tsetdef(left.resultdef).setbase=tsetdef(resultdef).setbase) then
  3790. { TODO: This causes wrong (but Delphi-compatible) results for disjoint subsets}
  3791. { e.g., this prints true because of this:
  3792. var
  3793. sa: set of 1..2;
  3794. sb: set of 5..6;
  3795. b: byte;
  3796. begin
  3797. b:=1;
  3798. sa:=[1..2];
  3799. sb:=sa;
  3800. writeln(b in sb);
  3801. end.
  3802. }
  3803. begin
  3804. result:=left;
  3805. left:=nil;
  3806. end
  3807. else
  3808. begin
  3809. result:=internalstatements(newstatement);
  3810. { in case left is a smallset expression, it can be an addn or so. }
  3811. { fpc_varset_load expects a formal const parameter, which doesn't }
  3812. { accept set addn's -> assign to a temp first and pass the temp }
  3813. if not(left.expectloc in [LOC_REFERENCE,LOC_CREFERENCE]) then
  3814. begin
  3815. temp:=ctempcreatenode.create(left.resultdef,left.resultdef.size,tt_persistent,false);
  3816. addstatement(newstatement,temp);
  3817. { temp := left }
  3818. addstatement(newstatement,cassignmentnode.create(
  3819. ctemprefnode.create(temp),left));
  3820. addstatement(newstatement,ctempdeletenode.create_normal_temp(temp));
  3821. addstatement(newstatement,ctemprefnode.create(temp));
  3822. left:=result;
  3823. firstpass(left);
  3824. { recreate the result's internalstatements list }
  3825. result:=internalstatements(newstatement);
  3826. end;
  3827. { create temp for result }
  3828. temp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,true);
  3829. addstatement(newstatement,temp);
  3830. addstatement(newstatement,ccallnode.createintern('fpc_varset_load',
  3831. ccallparanode.create(cordconstnode.create(tsetdef(left.resultdef).setbase div 8 - tsetdef(resultdef).setbase div 8,sinttype,false),
  3832. ccallparanode.create(cordconstnode.create(resultdef.size,sinttype,false),
  3833. ccallparanode.create(ctemprefnode.create(temp),
  3834. ccallparanode.create(cordconstnode.create(left.resultdef.size,sinttype,false),
  3835. ccallparanode.create(left,nil))))))
  3836. );
  3837. addstatement(newstatement,ctempdeletenode.create_normal_temp(temp));
  3838. addstatement(newstatement,ctemprefnode.create(temp));
  3839. left:=nil;
  3840. end;
  3841. end;
  3842. function ttypeconvnode.first_ansistring_to_pchar : tnode;
  3843. begin
  3844. first_ansistring_to_pchar:=nil;
  3845. expectloc:=LOC_REGISTER;
  3846. end;
  3847. function ttypeconvnode.first_arrayconstructor_to_set : tnode;
  3848. begin
  3849. first_arrayconstructor_to_set:=nil;
  3850. internalerror(200104022);
  3851. end;
  3852. function ttypeconvnode.first_class_to_intf : tnode;
  3853. var
  3854. hd : tobjectdef;
  3855. ImplIntf : TImplementedInterface;
  3856. begin
  3857. result:=nil;
  3858. expectloc:=LOC_REGISTER;
  3859. hd:=tobjectdef(left.resultdef);
  3860. while assigned(hd) do
  3861. begin
  3862. ImplIntf:=find_implemented_interface(hd,tobjectdef(resultdef));
  3863. if assigned(ImplIntf) then
  3864. begin
  3865. case ImplIntf.IType of
  3866. etStandard:
  3867. { handle in pass 2 }
  3868. ;
  3869. etFieldValue, etFieldValueClass:
  3870. if is_interface(tobjectdef(resultdef)) then
  3871. begin
  3872. result:=left;
  3873. propaccesslist_to_node(result,tpropertysym(implintf.implementsgetter).owner,tpropertysym(implintf.implementsgetter).propaccesslist[palt_read]);
  3874. { this ensures proper refcounting when field is of class type }
  3875. if not is_interface(result.resultdef) then
  3876. inserttypeconv(result, resultdef);
  3877. left:=nil;
  3878. end
  3879. else
  3880. begin
  3881. internalerror(200802213);
  3882. end;
  3883. etStaticMethodResult, etStaticMethodClass,
  3884. etVirtualMethodResult, etVirtualMethodClass:
  3885. if is_interface(tobjectdef(resultdef)) then
  3886. begin
  3887. { TODO: generating a call to TObject.GetInterface instead could yield
  3888. smaller code size. OTOH, refcounting gotchas are possible that way. }
  3889. { constructor create(l:tnode; v : tprocsym;st : TSymtable; mp: tnode; callflags:tcallnodeflags); }
  3890. result:=ccallnode.create(nil,tprocsym(tpropertysym(implintf.implementsgetter).propaccesslist[palt_read].firstsym^.sym),
  3891. tprocsym(tpropertysym(implintf.implementsgetter).propaccesslist[palt_read].firstsym^.sym).owner,
  3892. left,[],nil);
  3893. addsymref(tpropertysym(implintf.implementsgetter).propaccesslist[palt_read].firstsym^.sym);
  3894. { if it is a class, process it further in a similar way }
  3895. if not is_interface(result.resultdef) then
  3896. inserttypeconv(result, resultdef);
  3897. left:=nil;
  3898. end
  3899. else if is_class(tobjectdef(resultdef)) then
  3900. begin
  3901. internalerror(200802211);
  3902. end
  3903. else
  3904. internalerror(200802231);
  3905. end;
  3906. break;
  3907. end;
  3908. hd:=hd.childof;
  3909. end;
  3910. if hd=nil then
  3911. internalerror(200802164);
  3912. end;
  3913. function ttypeconvnode.first_string_to_string : tnode;
  3914. var
  3915. procname: string[31];
  3916. newblock : tblocknode;
  3917. newstat : tstatementnode;
  3918. restemp : ttempcreatenode;
  3919. begin
  3920. { get the correct procedure name }
  3921. procname := 'fpc_'+tstringdef(left.resultdef).stringtypname+
  3922. '_to_'+tstringdef(resultdef).stringtypname;
  3923. if tstringdef(resultdef).stringtype=st_shortstring then
  3924. begin
  3925. newblock:=internalstatements(newstat);
  3926. restemp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,false);
  3927. addstatement(newstat,restemp);
  3928. addstatement(newstat,ccallnode.createintern(procname,ccallparanode.create(left,ccallparanode.create(
  3929. ctemprefnode.create(restemp),nil))));
  3930. addstatement(newstat,ctempdeletenode.create_normal_temp(restemp));
  3931. addstatement(newstat,ctemprefnode.create(restemp));
  3932. result:=newblock;
  3933. end
  3934. { encoding parameter required? }
  3935. else if (tstringdef(resultdef).stringtype=st_ansistring) and
  3936. (tstringdef(left.resultdef).stringtype in [st_widestring,st_unicodestring,st_shortstring,st_ansistring]) then
  3937. result:=ccallnode.createinternres(procname,
  3938. ccallparanode.create(cordconstnode.create(getparaencoding(resultdef),u16inttype,true),
  3939. ccallparanode.create(left,nil)),resultdef)
  3940. else
  3941. result:=ccallnode.createinternres(procname,ccallparanode.create(left,nil),resultdef);
  3942. left:=nil;
  3943. end;
  3944. function ttypeconvnode._first_int_to_int : tnode;
  3945. begin
  3946. result:=first_int_to_int;
  3947. end;
  3948. function ttypeconvnode._first_cstring_to_pchar : tnode;
  3949. begin
  3950. result:=first_cstring_to_pchar;
  3951. end;
  3952. function ttypeconvnode._first_cstring_to_int : tnode;
  3953. begin
  3954. result:=first_cstring_to_int;
  3955. end;
  3956. function ttypeconvnode._first_string_to_chararray : tnode;
  3957. begin
  3958. result:=first_string_to_chararray;
  3959. end;
  3960. function ttypeconvnode._first_char_to_string : tnode;
  3961. begin
  3962. result:=first_char_to_string;
  3963. end;
  3964. function ttypeconvnode._first_char_to_chararray: tnode;
  3965. begin
  3966. result:=first_char_to_chararray;
  3967. end;
  3968. function ttypeconvnode._first_nothing : tnode;
  3969. begin
  3970. result:=first_nothing;
  3971. end;
  3972. function ttypeconvnode._first_array_to_pointer : tnode;
  3973. begin
  3974. result:=first_array_to_pointer;
  3975. end;
  3976. function ttypeconvnode._first_int_to_real : tnode;
  3977. begin
  3978. result:=first_int_to_real;
  3979. end;
  3980. function ttypeconvnode._first_real_to_real : tnode;
  3981. begin
  3982. result:=first_real_to_real;
  3983. end;
  3984. function ttypeconvnode._first_pointer_to_array : tnode;
  3985. begin
  3986. result:=first_pointer_to_array;
  3987. end;
  3988. function ttypeconvnode._first_cchar_to_pchar : tnode;
  3989. begin
  3990. result:=first_cchar_to_pchar;
  3991. end;
  3992. function ttypeconvnode._first_bool_to_int : tnode;
  3993. begin
  3994. result:=first_bool_to_int;
  3995. end;
  3996. function ttypeconvnode._first_int_to_bool : tnode;
  3997. begin
  3998. result:=first_int_to_bool;
  3999. end;
  4000. function ttypeconvnode._first_bool_to_bool : tnode;
  4001. begin
  4002. result:=first_bool_to_bool;
  4003. end;
  4004. function ttypeconvnode._first_proc_to_procvar : tnode;
  4005. begin
  4006. result:=first_proc_to_procvar;
  4007. end;
  4008. function ttypeconvnode._first_nil_to_methodprocvar : tnode;
  4009. begin
  4010. result:=first_nil_to_methodprocvar;
  4011. end;
  4012. function ttypeconvnode._first_set_to_set : tnode;
  4013. begin
  4014. result:=first_set_to_set;
  4015. end;
  4016. function ttypeconvnode._first_cord_to_pointer : tnode;
  4017. begin
  4018. result:=first_cord_to_pointer;
  4019. end;
  4020. function ttypeconvnode._first_ansistring_to_pchar : tnode;
  4021. begin
  4022. result:=first_ansistring_to_pchar;
  4023. end;
  4024. function ttypeconvnode._first_arrayconstructor_to_set : tnode;
  4025. begin
  4026. result:=first_arrayconstructor_to_set;
  4027. end;
  4028. function ttypeconvnode._first_class_to_intf : tnode;
  4029. begin
  4030. result:=first_class_to_intf;
  4031. end;
  4032. function ttypeconvnode._first_char_to_char : tnode;
  4033. begin
  4034. result:=first_char_to_char;
  4035. end;
  4036. function ttypeconvnode._first_string_to_string : tnode;
  4037. begin
  4038. result:=first_string_to_string;
  4039. end;
  4040. function ttypeconvnode.first_call_helper(c : tconverttype) : tnode;
  4041. const
  4042. firstconvert : array[tconverttype] of pointer = (
  4043. nil, { none }
  4044. @ttypeconvnode._first_nothing, {equal}
  4045. @ttypeconvnode._first_nothing, {not_possible}
  4046. @ttypeconvnode._first_string_to_string,
  4047. @ttypeconvnode._first_char_to_string,
  4048. @ttypeconvnode._first_char_to_chararray,
  4049. nil, { removed in typecheck_chararray_to_string }
  4050. @ttypeconvnode._first_cchar_to_pchar,
  4051. @ttypeconvnode._first_cstring_to_pchar,
  4052. @ttypeconvnode._first_cstring_to_int,
  4053. @ttypeconvnode._first_ansistring_to_pchar,
  4054. @ttypeconvnode._first_string_to_chararray,
  4055. nil, { removed in typecheck_chararray_to_string }
  4056. @ttypeconvnode._first_array_to_pointer,
  4057. @ttypeconvnode._first_pointer_to_array,
  4058. @ttypeconvnode._first_int_to_int,
  4059. @ttypeconvnode._first_int_to_bool,
  4060. @ttypeconvnode._first_bool_to_bool,
  4061. @ttypeconvnode._first_bool_to_int,
  4062. @ttypeconvnode._first_real_to_real,
  4063. @ttypeconvnode._first_int_to_real,
  4064. nil, { removed in typecheck_real_to_currency }
  4065. @ttypeconvnode._first_proc_to_procvar,
  4066. @ttypeconvnode._first_nil_to_methodprocvar,
  4067. @ttypeconvnode._first_arrayconstructor_to_set,
  4068. @ttypeconvnode._first_set_to_set,
  4069. @ttypeconvnode._first_cord_to_pointer,
  4070. @ttypeconvnode._first_nothing,
  4071. @ttypeconvnode._first_nothing,
  4072. @ttypeconvnode._first_class_to_intf,
  4073. @ttypeconvnode._first_char_to_char,
  4074. @ttypeconvnode._first_nothing,
  4075. @ttypeconvnode._first_nothing,
  4076. nil,
  4077. nil,
  4078. nil,
  4079. nil,
  4080. nil,
  4081. nil,
  4082. nil,
  4083. @ttypeconvnode._first_nothing,
  4084. @ttypeconvnode._first_nothing,
  4085. @ttypeconvnode._first_nothing,
  4086. nil,
  4087. nil
  4088. );
  4089. type
  4090. tprocedureofobject = function : tnode of object;
  4091. var
  4092. r : TMethod;
  4093. begin
  4094. { this is a little bit dirty but it works }
  4095. { and should be quite portable too }
  4096. r.Code:=firstconvert[c];
  4097. r.Data:=self;
  4098. if not assigned(r.Code) then
  4099. internalerror(200312081);
  4100. first_call_helper:=tprocedureofobject(r)()
  4101. end;
  4102. function ttypeconvnode.pass_1 : tnode;
  4103. begin
  4104. if warn_pointer_to_signed then
  4105. cgmessage(type_w_pointer_to_signed);
  4106. result:=nil;
  4107. firstpass(left);
  4108. if codegenerror then
  4109. exit;
  4110. expectloc:=left.expectloc;
  4111. if nf_explicit in flags then
  4112. { check if the result could be in a register }
  4113. if (not(tstoreddef(resultdef).is_intregable) and
  4114. not(tstoreddef(resultdef).is_const_intregable) and
  4115. not(tstoreddef(resultdef).is_fpuregable)) or
  4116. ((left.resultdef.typ = floatdef) and
  4117. (resultdef.typ <> floatdef)) then
  4118. make_not_regable(left,[ra_addr_regable]);
  4119. result:=first_call_helper(convtype);
  4120. end;
  4121. function ttypeconvnode.retains_value_location:boolean;
  4122. begin
  4123. result:=assigned(left.resultdef) and
  4124. (
  4125. (convtype=tc_equal) or
  4126. { typecasting from void is always allowed }
  4127. is_void(left.resultdef) or
  4128. (left.resultdef.typ=formaldef) or
  4129. { int 2 int with same size reuses same location, or for
  4130. tp7 mode also allow size < orignal size }
  4131. (
  4132. (convtype=tc_int_2_int) and
  4133. (
  4134. not is_bitpacked_access(left) and
  4135. (resultdef.size=left.resultdef.size) or
  4136. ((m_tp7 in current_settings.modeswitches) and
  4137. (resultdef.size<left.resultdef.size))
  4138. )
  4139. ) or
  4140. { int 2 bool/bool 2 int, explicit typecast, see also nx86cnv }
  4141. ((convtype in [tc_int_2_bool,tc_bool_2_int,tc_bool_2_bool]) and
  4142. (nf_explicit in flags) and
  4143. (resultdef.size=left.resultdef.size)) or
  4144. { on managed platforms, converting an element to an open array
  4145. involves creating an actual array -> value location changes }
  4146. ((convtype=tc_elem_2_openarray) and
  4147. not(target_info.system in systems_managed_vm))
  4148. );
  4149. end;
  4150. function ttypeconvnode.assign_allowed:boolean;
  4151. begin
  4152. result:=retains_value_location;
  4153. { When using only a part of the value it can't be in a register since
  4154. that will load the value in a new register first }
  4155. { the same goes for changing the sign of equal-sized values which
  4156. are smaller than an entire register }
  4157. if result and
  4158. { don't try to check the size of an open array }
  4159. (is_open_array(resultdef) or
  4160. (resultdef.size<left.resultdef.size) or
  4161. ((resultdef.size=left.resultdef.size) and
  4162. (left.resultdef.size<sizeof(aint)) and
  4163. (is_signed(resultdef) xor is_signed(left.resultdef)))) then
  4164. make_not_regable(left,[ra_addr_regable]);
  4165. end;
  4166. function ttypeconvnode.docompare(p: tnode) : boolean;
  4167. begin
  4168. docompare :=
  4169. inherited docompare(p) and
  4170. (convtype = ttypeconvnode(p).convtype) and
  4171. (convnodeflags = ttypeconvnode(p).convnodeflags) and
  4172. equal_defs(totypedef,ttypeconvnode(p).totypedef);
  4173. end;
  4174. procedure ttypeconvnode._second_int_to_int;
  4175. begin
  4176. second_int_to_int;
  4177. end;
  4178. procedure ttypeconvnode._second_string_to_string;
  4179. begin
  4180. second_string_to_string;
  4181. end;
  4182. procedure ttypeconvnode._second_cstring_to_pchar;
  4183. begin
  4184. second_cstring_to_pchar;
  4185. end;
  4186. procedure ttypeconvnode._second_cstring_to_int;
  4187. begin
  4188. second_cstring_to_int;
  4189. end;
  4190. procedure ttypeconvnode._second_string_to_chararray;
  4191. begin
  4192. second_string_to_chararray;
  4193. end;
  4194. procedure ttypeconvnode._second_array_to_pointer;
  4195. begin
  4196. second_array_to_pointer;
  4197. end;
  4198. procedure ttypeconvnode._second_pointer_to_array;
  4199. begin
  4200. second_pointer_to_array;
  4201. end;
  4202. procedure ttypeconvnode._second_chararray_to_string;
  4203. begin
  4204. second_chararray_to_string;
  4205. end;
  4206. procedure ttypeconvnode._second_char_to_string;
  4207. begin
  4208. second_char_to_string;
  4209. end;
  4210. procedure ttypeconvnode._second_int_to_real;
  4211. begin
  4212. second_int_to_real;
  4213. end;
  4214. procedure ttypeconvnode._second_real_to_real;
  4215. begin
  4216. second_real_to_real;
  4217. end;
  4218. procedure ttypeconvnode._second_cord_to_pointer;
  4219. begin
  4220. second_cord_to_pointer;
  4221. end;
  4222. procedure ttypeconvnode._second_proc_to_procvar;
  4223. begin
  4224. second_proc_to_procvar;
  4225. end;
  4226. procedure ttypeconvnode._second_nil_to_methodprocvar;
  4227. begin
  4228. second_nil_to_methodprocvar;
  4229. end;
  4230. procedure ttypeconvnode._second_bool_to_int;
  4231. begin
  4232. second_bool_to_int;
  4233. end;
  4234. procedure ttypeconvnode._second_int_to_bool;
  4235. begin
  4236. second_int_to_bool;
  4237. end;
  4238. procedure ttypeconvnode._second_bool_to_bool;
  4239. begin
  4240. second_bool_to_bool;
  4241. end;
  4242. procedure ttypeconvnode._second_set_to_set;
  4243. begin
  4244. second_set_to_set;
  4245. end;
  4246. procedure ttypeconvnode._second_ansistring_to_pchar;
  4247. begin
  4248. second_ansistring_to_pchar;
  4249. end;
  4250. procedure ttypeconvnode._second_class_to_intf;
  4251. begin
  4252. second_class_to_intf;
  4253. end;
  4254. procedure ttypeconvnode._second_char_to_char;
  4255. begin
  4256. second_char_to_char;
  4257. end;
  4258. procedure ttypeconvnode._second_elem_to_openarray;
  4259. begin
  4260. second_elem_to_openarray;
  4261. end;
  4262. procedure ttypeconvnode._second_nothing;
  4263. begin
  4264. second_nothing;
  4265. end;
  4266. procedure ttypeconvnode.second_call_helper(c : tconverttype);
  4267. const
  4268. secondconvert : array[tconverttype] of pointer = (
  4269. @ttypeconvnode._second_nothing, {none}
  4270. @ttypeconvnode._second_nothing, {equal}
  4271. @ttypeconvnode._second_nothing, {not_possible}
  4272. @ttypeconvnode._second_nothing, {second_string_to_string, handled in resultdef pass }
  4273. @ttypeconvnode._second_char_to_string,
  4274. @ttypeconvnode._second_nothing, {char_to_charray}
  4275. @ttypeconvnode._second_nothing, { pchar_to_string, handled in resultdef pass }
  4276. @ttypeconvnode._second_nothing, {cchar_to_pchar}
  4277. @ttypeconvnode._second_cstring_to_pchar,
  4278. @ttypeconvnode._second_cstring_to_int,
  4279. @ttypeconvnode._second_ansistring_to_pchar,
  4280. @ttypeconvnode._second_string_to_chararray,
  4281. @ttypeconvnode._second_nothing, { chararray_to_string, handled in resultdef pass }
  4282. @ttypeconvnode._second_array_to_pointer,
  4283. @ttypeconvnode._second_pointer_to_array,
  4284. @ttypeconvnode._second_int_to_int,
  4285. @ttypeconvnode._second_int_to_bool,
  4286. @ttypeconvnode._second_bool_to_bool,
  4287. @ttypeconvnode._second_bool_to_int,
  4288. @ttypeconvnode._second_real_to_real,
  4289. @ttypeconvnode._second_int_to_real,
  4290. @ttypeconvnode._second_nothing, { real_to_currency, handled in resultdef pass }
  4291. @ttypeconvnode._second_proc_to_procvar,
  4292. @ttypeconvnode._second_nil_to_methodprocvar,
  4293. @ttypeconvnode._second_nothing, { arrayconstructor_to_set }
  4294. @ttypeconvnode._second_nothing, { second_set_to_set, handled in first pass }
  4295. @ttypeconvnode._second_cord_to_pointer,
  4296. @ttypeconvnode._second_nothing, { interface 2 string }
  4297. @ttypeconvnode._second_nothing, { interface 2 guid }
  4298. @ttypeconvnode._second_class_to_intf,
  4299. @ttypeconvnode._second_char_to_char,
  4300. @ttypeconvnode._second_nothing, { dynarray_2_openarray }
  4301. @ttypeconvnode._second_nothing, { pwchar_2_string }
  4302. @ttypeconvnode._second_nothing, { variant_2_dynarray }
  4303. @ttypeconvnode._second_nothing, { dynarray_2_variant}
  4304. @ttypeconvnode._second_nothing, { variant_2_enum }
  4305. @ttypeconvnode._second_nothing, { enum_2_variant }
  4306. @ttypeconvnode._second_nothing, { variant_2_interface }
  4307. @ttypeconvnode._second_nothing, { interface_2_variant }
  4308. @ttypeconvnode._second_nothing, { array_2_dynarray }
  4309. @ttypeconvnode._second_elem_to_openarray, { elem_2_openarray }
  4310. @ttypeconvnode._second_nothing, { arrayconstructor_2_dynarray }
  4311. @ttypeconvnode._second_nothing, { arrayconstructor_2_array }
  4312. @ttypeconvnode._second_nothing, { anonproc_2_funcref }
  4313. @ttypeconvnode._second_nothing { procvar_2_funcref }
  4314. );
  4315. type
  4316. tprocedureofobject = procedure of object;
  4317. var
  4318. r : TMethod;
  4319. begin
  4320. { this is a little bit dirty but it works }
  4321. { and should be quite portable too }
  4322. r.Code:=secondconvert[c];
  4323. r.Data:=self;
  4324. tprocedureofobject(r)();
  4325. end;
  4326. {*****************************************************************************
  4327. TASNODE
  4328. *****************************************************************************}
  4329. function tasisnode.target_specific_typecheck: boolean;
  4330. begin
  4331. result:=false;
  4332. end;
  4333. function tasisnode.pass_typecheck: tnode;
  4334. var
  4335. hp : tnode;
  4336. begin
  4337. result:=nil;
  4338. typecheckpass(right);
  4339. typecheckpass(left);
  4340. set_varstate(right,vs_read,[vsf_must_be_valid]);
  4341. set_varstate(left,vs_read,[vsf_must_be_valid]);
  4342. if codegenerror then
  4343. exit;
  4344. if target_specific_typecheck then
  4345. begin
  4346. // ok
  4347. end
  4348. else if (right.resultdef.typ=classrefdef) then
  4349. begin
  4350. { left maybe an interface reference }
  4351. if is_interfacecom(left.resultdef) or
  4352. is_javainterface(left.resultdef) then
  4353. begin
  4354. { relation checks are not possible }
  4355. end
  4356. { or left must be a class }
  4357. else if is_class(left.resultdef) or
  4358. is_javaclass(left.resultdef) then
  4359. begin
  4360. { the operands must be related }
  4361. if (not(def_is_related(tobjectdef(left.resultdef),
  4362. tobjectdef(tclassrefdef(right.resultdef).pointeddef)))) and
  4363. (not(def_is_related(tobjectdef(tclassrefdef(right.resultdef).pointeddef),
  4364. tobjectdef(left.resultdef)))) then
  4365. CGMessage2(type_e_classes_not_related,
  4366. FullTypeName(left.resultdef,tclassrefdef(right.resultdef).pointeddef),
  4367. FullTypeName(tclassrefdef(right.resultdef).pointeddef,left.resultdef));
  4368. end
  4369. else
  4370. CGMessage1(type_e_class_or_cominterface_type_expected,left.resultdef.typename);
  4371. case nodetype of
  4372. isn:
  4373. resultdef:=pasbool1type;
  4374. asn:
  4375. resultdef:=tclassrefdef(right.resultdef).pointeddef;
  4376. else
  4377. ;
  4378. end;
  4379. end
  4380. else if is_interface(right.resultdef) or
  4381. is_dispinterface(right.resultdef) or
  4382. is_javainterface(right.resultdef) then
  4383. begin
  4384. case nodetype of
  4385. isn:
  4386. resultdef:=pasbool1type;
  4387. asn:
  4388. resultdef:=right.resultdef;
  4389. else
  4390. ;
  4391. end;
  4392. { left is a class or interface }
  4393. if is_javainterface(right.resultdef) then
  4394. begin
  4395. if not is_java_class_or_interface(left.resultdef) then
  4396. CGMessage1(type_e_class_or_cominterface_type_expected,left.resultdef.typename);
  4397. end
  4398. else if not(is_class(left.resultdef) or
  4399. is_interfacecom(left.resultdef)) then
  4400. CGMessage1(type_e_class_or_cominterface_type_expected,left.resultdef.typename)
  4401. else
  4402. begin
  4403. { load the GUID of the interface }
  4404. if (right.nodetype=typen) then
  4405. begin
  4406. if tobjectdef(right.resultdef).objecttype=odt_interfacecorba then
  4407. begin
  4408. if assigned(tobjectdef(right.resultdef).iidstr) then
  4409. begin
  4410. hp:=cstringconstnode.createstr(tobjectdef(right.resultdef).iidstr^);
  4411. tstringconstnode(hp).changestringtype(cshortstringtype);
  4412. right.free;
  4413. right:=hp;
  4414. end
  4415. else
  4416. internalerror(201006131);
  4417. end
  4418. else
  4419. begin
  4420. if assigned(tobjectdef(right.resultdef).iidguid) then
  4421. begin
  4422. if not(oo_has_valid_guid in tobjectdef(right.resultdef).objectoptions) then
  4423. CGMessage1(type_e_interface_has_no_guid,tobjectdef(right.resultdef).typename);
  4424. hp:=cguidconstnode.create(tobjectdef(right.resultdef).iidguid^);
  4425. right.free;
  4426. right:=hp;
  4427. end
  4428. else
  4429. internalerror(201006132);
  4430. end;
  4431. typecheckpass(right);
  4432. end;
  4433. end;
  4434. end
  4435. else
  4436. CGMessage1(type_e_class_or_interface_type_expected,right.resultdef.typename);
  4437. end;
  4438. {*****************************************************************************
  4439. TISNODE
  4440. *****************************************************************************}
  4441. constructor tisnode.create(l,r : tnode);
  4442. begin
  4443. inherited create(isn,l,r);
  4444. end;
  4445. constructor tisnode.create_internal(l, r: tnode);
  4446. begin
  4447. create(l,r);
  4448. include(flags,nf_internal);
  4449. end;
  4450. function tisnode.pass_1 : tnode;
  4451. var
  4452. procname: string;
  4453. statement : tstatementnode;
  4454. tempnode : ttempcreatenode;
  4455. begin
  4456. result:=nil;
  4457. { Passing a class type to an "is" expression cannot result in a class
  4458. of that type to be constructed.
  4459. }
  4460. include(right.flags,nf_ignore_for_wpo);
  4461. if is_class(left.resultdef) and
  4462. (right.resultdef.typ=classrefdef) then
  4463. begin
  4464. if (right.nodetype=loadvmtaddrn) and
  4465. (tloadvmtaddrnode(right).left.nodetype=typen) and
  4466. (oo_is_sealed in tobjectdef(tloadvmtaddrnode(right).left.resultdef).objectoptions) and
  4467. equal_defs(left.resultdef,tclassrefdef(right.resultdef).pointeddef) then
  4468. begin
  4469. if might_have_sideeffects(left) or
  4470. (node_complexity(left)>2) then
  4471. begin
  4472. result:=internalstatements(statement);
  4473. tempnode:=ctempcreatenode.create(left.resultdef,left.resultdef.size,tt_persistent,true);
  4474. addstatement(statement,tempnode);
  4475. addstatement(statement,cassignmentnode.create_internal(ctemprefnode.create(tempnode),left));
  4476. addstatement(statement,caddnode.create_internal(andn,
  4477. caddnode.create_internal(unequaln,ctemprefnode.create(tempnode),cnilnode.create),
  4478. caddnode.create_internal(equaln,cloadvmtaddrnode.create(ctemprefnode.create(tempnode)),right)
  4479. )
  4480. );
  4481. left:=nil;
  4482. right:=nil;
  4483. end
  4484. else
  4485. begin
  4486. result:=caddnode.create_internal(andn,
  4487. caddnode.create_internal(unequaln,left.getcopy,cnilnode.create),
  4488. caddnode.create_internal(equaln,cloadvmtaddrnode.create(left.getcopy),right)
  4489. );
  4490. right:=nil;
  4491. end;
  4492. end
  4493. else
  4494. result := ccallnode.createinternres('fpc_do_is',
  4495. ccallparanode.create(left,ccallparanode.create(right,nil)),
  4496. resultdef);
  4497. end
  4498. else
  4499. begin
  4500. if is_class(left.resultdef) then
  4501. if is_shortstring(right.resultdef) then
  4502. procname := 'fpc_class_is_corbaintf'
  4503. else
  4504. procname := 'fpc_class_is_intf'
  4505. else
  4506. if right.resultdef.typ=classrefdef then
  4507. procname := 'fpc_intf_is_class'
  4508. else
  4509. procname := 'fpc_intf_is';
  4510. result := ctypeconvnode.create_internal(ccallnode.createintern(procname,
  4511. ccallparanode.create(right,ccallparanode.create(left,nil))),resultdef);
  4512. end;
  4513. left := nil;
  4514. right := nil;
  4515. //firstpass(call);
  4516. if codegenerror then
  4517. exit;
  4518. end;
  4519. { dummy pass_2, it will never be called, but we need one since }
  4520. { you can't instantiate an abstract class }
  4521. procedure tisnode.pass_generate_code;
  4522. begin
  4523. end;
  4524. {*****************************************************************************
  4525. TASNODE
  4526. *****************************************************************************}
  4527. constructor tasnode.create(l,r : tnode);
  4528. begin
  4529. inherited create(asn,l,r);
  4530. call := nil;
  4531. end;
  4532. constructor tasnode.create_internal(l,r : tnode);
  4533. begin
  4534. create(l,r);
  4535. include(flags,nf_internal);
  4536. end;
  4537. destructor tasnode.destroy;
  4538. begin
  4539. call.free;
  4540. inherited destroy;
  4541. end;
  4542. function tasnode.dogetcopy: tnode;
  4543. begin
  4544. result := inherited dogetcopy;
  4545. if assigned(call) then
  4546. tasnode(result).call := call.getcopy
  4547. else
  4548. tasnode(result).call := nil;
  4549. end;
  4550. function tasnode.docompare(p: tnode): boolean;
  4551. begin
  4552. result:=
  4553. inherited docompare(p) and
  4554. tasnode(p).call.isequal(call);
  4555. end;
  4556. function tasnode.pass_1 : tnode;
  4557. var
  4558. procname: string;
  4559. begin
  4560. result:=nil;
  4561. { Passing a class type to an "as" expression cannot result in a class
  4562. of that type to be constructed.
  4563. We could put this inside the if-block below, but this way it is
  4564. safe for sure even if the code below changes
  4565. }
  4566. if assigned(right) then
  4567. include(right.flags,nf_ignore_for_wpo);
  4568. if not assigned(call) then
  4569. begin
  4570. if is_class(left.resultdef) and
  4571. (right.resultdef.typ=classrefdef) then
  4572. call := ccallnode.createinternres('fpc_do_as',
  4573. ccallparanode.create(left,ccallparanode.create(right,nil)),
  4574. resultdef)
  4575. else
  4576. begin
  4577. if is_class(left.resultdef) then
  4578. if is_shortstring(right.resultdef) then
  4579. procname := 'fpc_class_as_corbaintf'
  4580. else
  4581. procname := 'fpc_class_as_intf'
  4582. else
  4583. if right.resultdef.typ=classrefdef then
  4584. procname := 'fpc_intf_as_class'
  4585. else
  4586. procname := 'fpc_intf_as';
  4587. call := ctypeconvnode.create_internal(ccallnode.createintern(procname,
  4588. ccallparanode.create(right,ccallparanode.create(left,nil))),resultdef);
  4589. end;
  4590. left := nil;
  4591. right := nil;
  4592. firstpass(call);
  4593. if codegenerror then
  4594. exit;
  4595. expectloc:=call.expectloc;
  4596. end;
  4597. end;
  4598. end.