ninl.pas 211 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417
  1. {
  2. Copyright (c) 1998-2007 by Florian Klaempfl
  3. Type checking and register allocation for inline 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 ninl;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. node,htypechk,symtype,compinnr;
  22. type
  23. tinlinenode = class(tunarynode)
  24. inlinenumber : tinlinenumber;
  25. constructor create(number : tinlinenumber;is_const:boolean;l : tnode);virtual;
  26. constructor createintern(number : tinlinenumber;is_const:boolean;l : tnode);virtual;
  27. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  28. procedure ppuwrite(ppufile:tcompilerppufile);override;
  29. function dogetcopy : tnode;override;
  30. procedure printnodeinfo(var t : text);override;
  31. {$ifdef DEBUG_NODE_XML}
  32. procedure XMLPrintNodeInfo(var t : text);override;
  33. {$endif DEBUG_NODE_XML}
  34. function pass_1 : tnode;override;
  35. function pass_typecheck:tnode;override;
  36. function pass_typecheck_cpu:tnode;virtual;
  37. function simplify(forinline : boolean): tnode;override;
  38. function docompare(p: tnode): boolean; override;
  39. procedure mark_write;override;
  40. { returns a node tree where the inc/dec are replaced by add/sub }
  41. function getaddsub_for_incdec : tnode;
  42. { pack and unpack are changed into for-loops by the compiler }
  43. function first_pack_unpack: tnode; virtual;
  44. property parameters : tnode read left write left;
  45. function may_have_sideeffect_norecurse: boolean;
  46. protected
  47. { All the following routines currently
  48. call compilerprocs, unless they are
  49. overridden in which case, the code
  50. generator handles them.
  51. }
  52. function first_pi: tnode ; virtual;
  53. function first_arctan_real: tnode; virtual;
  54. function first_abs_real: tnode; virtual;
  55. function first_sqr_real: tnode; virtual;
  56. function first_sqrt_real: tnode; virtual;
  57. function first_ln_real: tnode; virtual;
  58. function first_cos_real: tnode; virtual;
  59. function first_sin_real: tnode; virtual;
  60. function first_exp_real: tnode; virtual;
  61. function first_frac_real: tnode; virtual;
  62. function first_round_real: tnode; virtual;
  63. function first_trunc_real: tnode; virtual;
  64. function first_int_real: tnode; virtual;
  65. function first_abs_long: tnode; virtual;
  66. function first_IncDec: tnode; virtual;
  67. function first_IncludeExclude: tnode; virtual;
  68. function first_get_frame: tnode; virtual;
  69. function first_setlength: tnode; virtual;
  70. function first_copy: tnode; virtual;
  71. { This one by default generates an internal error, because such
  72. nodes are not generated by the parser. It's however used internally
  73. by the JVM backend to create new dynamic arrays. }
  74. function first_new: tnode; virtual;
  75. function first_length: tnode; virtual;
  76. function first_high: tnode; virtual;
  77. function first_box: tnode; virtual; abstract;
  78. function first_unbox: tnode; virtual; abstract;
  79. function first_assigned: tnode; virtual;
  80. function first_assert: tnode; virtual;
  81. function first_popcnt: tnode; virtual;
  82. function first_bitscan: tnode; virtual;
  83. { override these for Seg() support }
  84. function typecheck_seg: tnode; virtual;
  85. function first_seg: tnode; virtual;
  86. function first_sar: tnode; virtual;
  87. function first_fma : tnode; virtual;
  88. {$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
  89. function first_ShiftRot_assign_64bitint: tnode; virtual;
  90. {$endif not cpu64bitalu and not cpuhighleveltarget}
  91. function first_AndOrXorShiftRot_assign: tnode; virtual;
  92. function first_NegNot_assign: tnode; virtual;
  93. function first_cpu : tnode; virtual;
  94. procedure CheckParameters(count : integer);
  95. private
  96. function handle_str: tnode;
  97. function handle_reset_rewrite_typed: tnode;
  98. function handle_text_read_write(filepara,params:Ttertiarynode;var newstatement:Tnode):boolean;
  99. function handle_typed_read_write(filepara,params:Ttertiarynode;var newstatement:Tnode):boolean;
  100. function handle_read_write: tnode;
  101. function handle_val: tnode;
  102. function handle_default: tnode;
  103. function handle_setlength: tnode;
  104. function handle_copy: tnode;
  105. function handle_box: tnode;
  106. function handle_unbox: tnode;
  107. function handle_insert:tnode;
  108. function handle_delete:tnode;
  109. function handle_concat:tnode;
  110. end;
  111. tinlinenodeclass = class of tinlinenode;
  112. var
  113. cinlinenode : tinlinenodeclass = tinlinenode;
  114. function geninlinenode(number : tinlinenumber;is_const:boolean;l : tnode) : tinlinenode;
  115. implementation
  116. uses
  117. verbose,globals,systems,constexp,
  118. globtype,cutils,cclasses,fmodule,
  119. symconst,symdef,symsym,symcpu,symtable,paramgr,defcmp,defutil,symbase,
  120. cpuinfo,cpubase,
  121. pass_1,
  122. ncal,ncon,ncnv,nadd,nld,nbas,nflw,nmem,nmat,nutils,
  123. nobjc,objcdef,
  124. cgbase,procinfo;
  125. function geninlinenode(number : tinlinenumber;is_const:boolean;l : tnode) : tinlinenode;
  126. begin
  127. geninlinenode:=cinlinenode.create(number,is_const,l);
  128. end;
  129. {*****************************************************************************
  130. TINLINENODE
  131. *****************************************************************************}
  132. constructor tinlinenode.create(number : tinlinenumber;is_const:boolean;l : tnode);
  133. begin
  134. inherited create(inlinen,l);
  135. if is_const then
  136. include(flags,nf_inlineconst);
  137. inlinenumber:=number;
  138. end;
  139. constructor tinlinenode.createintern(number : tinlinenumber; is_const : boolean;
  140. l : tnode);
  141. begin
  142. create(number,is_const,l);
  143. include(flags,nf_internal);
  144. end;
  145. constructor tinlinenode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  146. begin
  147. inherited ppuload(t,ppufile);
  148. inlinenumber:=tinlinenumber(ppufile.getlongint);
  149. end;
  150. procedure tinlinenode.ppuwrite(ppufile:tcompilerppufile);
  151. begin
  152. inherited ppuwrite(ppufile);
  153. ppufile.putlongint(longint(inlinenumber));
  154. end;
  155. function tinlinenode.dogetcopy : tnode;
  156. var
  157. n : tinlinenode;
  158. begin
  159. n:=tinlinenode(inherited dogetcopy);
  160. n.inlinenumber:=inlinenumber;
  161. result:=n;
  162. end;
  163. procedure tinlinenode.printnodeinfo(var t : text);
  164. begin
  165. inherited;
  166. write(t,', inlinenumber = ',inlinenumber);
  167. end;
  168. {$ifdef DEBUG_NODE_XML}
  169. procedure TInlineNode.XMLPrintNodeInfo(var T: Text);
  170. begin
  171. inherited;
  172. Write(T, ' inlinenumber="', inlinenumber, '"');
  173. end;
  174. {$endif DEBUG_NODE_XML}
  175. function get_str_int_func(def: tdef): string;
  176. var
  177. ordtype: tordtype;
  178. begin
  179. ordtype := torddef(def).ordtype;
  180. if not (ordtype in [scurrency,s64bit,u64bit,s32bit,u32bit,s16bit,u16bit,s8bit,u8bit]) then
  181. internalerror(2013032603);
  182. if is_oversizedord(def) then
  183. begin
  184. case ordtype of
  185. scurrency,
  186. s64bit: exit('int64');
  187. u64bit: exit('qword');
  188. s32bit: exit('longint');
  189. u32bit: exit('longword');
  190. s16bit: exit('smallint');
  191. u16bit: exit('word');
  192. else
  193. internalerror(2013032604);
  194. end;
  195. end
  196. else
  197. begin
  198. if is_nativeuint(def) then
  199. exit('uint')
  200. else
  201. exit('sint');
  202. end;
  203. internalerror(2013032605);
  204. end;
  205. function tinlinenode.handle_str : tnode;
  206. var
  207. lenpara,
  208. fracpara,
  209. newparas,
  210. tmppara,
  211. dest,
  212. source : tcallparanode;
  213. procname: string;
  214. is_real,is_enum : boolean;
  215. rt : aint;
  216. begin
  217. result := cerrornode.create;
  218. { get destination string }
  219. dest := tcallparanode(left);
  220. { get source para (number) }
  221. source := dest;
  222. while assigned(source.right) do
  223. source := tcallparanode(source.right);
  224. { destination parameter must be a normal (not a colon) parameter, this
  225. check is needed because str(v:len) also has 2 parameters }
  226. if (source=dest) or
  227. (cpf_is_colon_para in tcallparanode(dest).callparaflags) then
  228. begin
  229. CGMessage1(parser_e_wrong_parameter_size,'Str');
  230. exit;
  231. end;
  232. { in case we are in a generic definition, we cannot
  233. do all checks, the parameters might be type parameters }
  234. if df_generic in current_procinfo.procdef.defoptions then
  235. begin
  236. result.Free;
  237. result:=nil;
  238. resultdef:=voidtype;
  239. exit;
  240. end;
  241. is_real:=(source.resultdef.typ = floatdef) or is_currency(source.resultdef);
  242. is_enum:=source.left.resultdef.typ=enumdef;
  243. if ((dest.left.resultdef.typ<>stringdef) and
  244. not(is_chararray(dest.left.resultdef))) or
  245. not(is_real or is_enum or
  246. (source.left.resultdef.typ=orddef)) then
  247. begin
  248. CGMessagePos(fileinfo,parser_e_illegal_expression);
  249. exit;
  250. end;
  251. { get len/frac parameters }
  252. lenpara := nil;
  253. fracpara := nil;
  254. if (cpf_is_colon_para in tcallparanode(dest.right).callparaflags) then
  255. begin
  256. lenpara := tcallparanode(dest.right);
  257. { we can let the callnode do the type checking of these parameters too, }
  258. { but then the error messages aren't as nice }
  259. if not is_integer(lenpara.resultdef) then
  260. begin
  261. CGMessagePos1(lenpara.fileinfo,
  262. type_e_integer_expr_expected,lenpara.resultdef.typename);
  263. exit;
  264. end;
  265. if (cpf_is_colon_para in tcallparanode(lenpara.right).callparaflags) then
  266. begin
  267. { parameters are in reverse order! }
  268. fracpara := lenpara;
  269. lenpara := tcallparanode(lenpara.right);
  270. if not is_real then
  271. begin
  272. CGMessagePos(lenpara.fileinfo,parser_e_illegal_colon_qualifier);
  273. exit
  274. end;
  275. if not is_integer(lenpara.resultdef) then
  276. begin
  277. CGMessagePos1(lenpara.fileinfo,
  278. type_e_integer_expr_expected,lenpara.resultdef.typename);
  279. exit;
  280. end;
  281. end;
  282. end;
  283. { generate the parameter list for the compilerproc }
  284. newparas := dest;
  285. { if we have a float parameter, insert the realtype, len and fracpara parameters }
  286. if is_real then
  287. begin
  288. { insert realtype parameter }
  289. if not is_currency(source.resultdef) then
  290. begin
  291. rt:=ord(tfloatdef(source.left.resultdef).floattype);
  292. newparas.right := ccallparanode.create(cordconstnode.create(
  293. rt,s32inttype,true),newparas.right);
  294. tmppara:=tcallparanode(newparas.right);
  295. end
  296. else
  297. tmppara:=newparas;
  298. { if necessary, insert a fraction parameter }
  299. if not assigned(fracpara) then
  300. begin
  301. tmppara.right := ccallparanode.create(
  302. cordconstnode.create(int64(-1),s32inttype,false),
  303. tmppara.right);
  304. fracpara := tcallparanode(tmppara.right);
  305. end;
  306. { if necessary, insert a length para }
  307. if not assigned(lenpara) then
  308. fracpara.right := ccallparanode.create(
  309. cordconstnode.create(int64(-32767),s32inttype,false),
  310. fracpara.right);
  311. end
  312. else if is_enum then
  313. begin
  314. {Insert a reference to the ord2string index.}
  315. newparas.right:=Ccallparanode.create(
  316. Caddrnode.create_internal(
  317. Crttinode.create(Tenumdef(source.left.resultdef),fullrtti,rdt_normal)
  318. ),
  319. newparas.right);
  320. {Insert a reference to the typinfo.}
  321. newparas.right:=Ccallparanode.create(
  322. Caddrnode.create_internal(
  323. Crttinode.create(Tenumdef(source.left.resultdef),fullrtti,rdt_ord2str)
  324. ),
  325. newparas.right);
  326. {Insert a type conversion from the enumeration to longint.}
  327. source.left:=Ctypeconvnode.create_internal(source.left,s32inttype);
  328. typecheckpass(source.left);
  329. { if necessary, insert a length para }
  330. if not assigned(lenpara) then
  331. Tcallparanode(Tcallparanode(newparas.right).right).right:=
  332. Ccallparanode.create(
  333. cordconstnode.create(int64(-1),s32inttype,false),
  334. Tcallparanode(Tcallparanode(newparas.right).right).right
  335. );
  336. end
  337. else
  338. { for a normal parameter, insert a only length parameter if one is missing }
  339. if not assigned(lenpara) then
  340. newparas.right := ccallparanode.create(cordconstnode.create(int64(-1),s32inttype,false),
  341. newparas.right);
  342. { remove the parameters from the original node so they won't get disposed, }
  343. { since they're reused }
  344. left := nil;
  345. { create procedure name }
  346. if is_chararray(dest.resultdef) then
  347. procname:='fpc_chararray_'
  348. else
  349. procname := 'fpc_' + tstringdef(dest.resultdef).stringtypname+'_';
  350. if is_real then
  351. if is_currency(source.resultdef) then
  352. procname := procname + 'currency'
  353. else
  354. procname := procname + 'float'
  355. else if is_enum then
  356. procname:=procname+'enum'
  357. else
  358. case torddef(source.resultdef).ordtype of
  359. pasbool1,pasbool8,pasbool16,pasbool32,pasbool64,
  360. bool8bit,bool16bit,bool32bit,bool64bit:
  361. procname := procname + 'bool';
  362. else
  363. procname := procname + get_str_int_func(source.resultdef);
  364. end;
  365. { for ansistrings insert the encoding argument }
  366. if is_ansistring(dest.resultdef) then
  367. newparas:=ccallparanode.create(cordconstnode.create(
  368. getparaencoding(dest.resultdef),u16inttype,true),newparas);
  369. { free the errornode we generated in the beginning }
  370. result.free;
  371. { create the call node, }
  372. result := ccallnode.createintern(procname,newparas);
  373. end;
  374. function tinlinenode.handle_default: tnode;
  375. function getdefaultvarsym(def:tdef):tnode;
  376. var
  377. hashedid : thashedidstring;
  378. srsym : tsym;
  379. srsymtable : tsymtable;
  380. defaultname : tidstring;
  381. begin
  382. if not assigned(def) or
  383. not (def.typ in [arraydef,recorddef,variantdef,objectdef,procvardef]) or
  384. ((def.typ=objectdef) and not is_object(def)) then
  385. internalerror(201202101);
  386. { extra '$' prefix because on darwin the result of makemangledname
  387. is prefixed by '_' and hence adding a '$' at the start of the
  388. prefix passed to makemangledname doesn't help (the whole point of
  389. the copy() operation below is to ensure that the id does not start
  390. with a '$', because that is interpreted specially by the symtable
  391. routines -- that's also why we prefix with '$_', so it will still
  392. work if make_mangledname() would somehow return a name that already
  393. starts with '$' }
  394. defaultname:='$_'+make_mangledname('zero',def.owner,def.typesym.Name);
  395. { can't hardcode the position of the '$', e.g. on darwin an underscore
  396. is added }
  397. hashedid.id:=copy(defaultname,2,255);
  398. { the default sym is always part of the current procedure/function }
  399. srsymtable:=current_procinfo.procdef.localst;
  400. srsym:=tsym(srsymtable.findwithhash(hashedid));
  401. if not assigned(srsym) then
  402. begin
  403. { no valid default variable found, so create it }
  404. srsym:=clocalvarsym.create(defaultname,vs_const,def,[]);
  405. srsymtable.insert(srsym);
  406. { mark the staticvarsym as typedconst }
  407. include(tabstractvarsym(srsym).varoptions,vo_is_typed_const);
  408. include(tabstractvarsym(srsym).varoptions,vo_is_default_var);
  409. { The variable has a value assigned }
  410. tabstractvarsym(srsym).varstate:=vs_initialised;
  411. { the variable can't be placed in a register }
  412. tabstractvarsym(srsym).varregable:=vr_none;
  413. end;
  414. result:=cloadnode.create(srsym,srsymtable);
  415. end;
  416. var
  417. def : tdef;
  418. begin
  419. if not assigned(left) or (left.nodetype<>typen) then
  420. internalerror(2012032101);
  421. def:=ttypenode(left).typedef;
  422. result:=nil;
  423. case def.typ of
  424. enumdef,
  425. orddef:
  426. { don't do a rangecheck as Default will also return 0
  427. for the following types (Delphi compatible):
  428. TRange1 = -10..-5;
  429. TRange2 = 5..10;
  430. TEnum = (a:=5;b:=10); }
  431. result:=cordconstnode.create(0,def,false);
  432. classrefdef,
  433. pointerdef:
  434. result:=cpointerconstnode.create(0,def);
  435. procvardef:
  436. if tprocvardef(def).size<>sizeof(pint) then
  437. result:=getdefaultvarsym(def)
  438. else
  439. result:=cpointerconstnode.create(0,def);
  440. stringdef:
  441. result:=cstringconstnode.createstr('');
  442. floatdef:
  443. result:=crealconstnode.create(0,def);
  444. objectdef:
  445. begin
  446. if is_implicit_pointer_object_type(def) then
  447. result:=cpointerconstnode.create(0,def)
  448. else
  449. if is_object(def) then
  450. begin
  451. { Delphi does not recursively check whether
  452. an object contains unsupported types }
  453. if not (m_delphi in current_settings.modeswitches) and
  454. not is_valid_for_default(def) then
  455. Message(type_e_type_not_allowed_for_default);
  456. result:=getdefaultvarsym(def);
  457. end
  458. else
  459. Message(type_e_type_not_allowed_for_default);
  460. end;
  461. variantdef,
  462. recorddef:
  463. begin
  464. { Delphi does not recursively check whether a record
  465. contains unsupported types }
  466. if (def.typ=recorddef) and not (m_delphi in current_settings.modeswitches) and
  467. not is_valid_for_default(def) then
  468. Message(type_e_type_not_allowed_for_default);
  469. result:=getdefaultvarsym(def);
  470. end;
  471. setdef:
  472. begin
  473. result:=csetconstnode.create(nil,def);
  474. New(tsetconstnode(result).value_set);
  475. tsetconstnode(result).value_set^:=[];
  476. end;
  477. arraydef:
  478. begin
  479. { can other array types be parsed by single_type? }
  480. if ado_isdynamicarray in tarraydef(def).arrayoptions then
  481. result:=cpointerconstnode.create(0,def)
  482. else
  483. begin
  484. result:=getdefaultvarsym(def);
  485. end;
  486. end;
  487. undefineddef:
  488. begin
  489. if sp_generic_dummy in def.typesym.symoptions then
  490. begin
  491. { this matches the error messages that are printed
  492. in case of non-Delphi modes }
  493. Message(parser_e_no_generics_as_types);
  494. Message(type_e_type_id_expected);
  495. end
  496. else
  497. result:=cpointerconstnode.create(0,def);
  498. end;
  499. else
  500. Message(type_e_type_not_allowed_for_default);
  501. end;
  502. if not assigned(result) then
  503. result:=cerrornode.create;
  504. end;
  505. function tinlinenode.handle_reset_rewrite_typed: tnode;
  506. begin
  507. { since this is a "in_xxxx_typedfile" node, we can be sure we have }
  508. { a typed file as argument and we don't have to check it again (JM) }
  509. { add the recsize parameter }
  510. { iso mode extension with name? }
  511. if inlinenumber in [in_reset_typedfile_name,in_rewrite_typedfile_name] then
  512. begin
  513. left := ccallparanode.create(cordconstnode.create(
  514. tfiledef(tcallparanode(tcallparanode(left).nextpara).paravalue.resultdef).typedfiledef.size,s32inttype,true),left);
  515. end
  516. else
  517. begin
  518. { note: for some reason, the parameter of intern procedures with only one }
  519. { parameter is gets lifted out of its original tcallparanode (see round }
  520. { line 1306 of ncal.pas), so recreate a tcallparanode here (JM) }
  521. left := ccallparanode.create(cordconstnode.create(
  522. tfiledef(left.resultdef).typedfiledef.size,s32inttype,true),
  523. ccallparanode.create(left,nil));
  524. end;
  525. { create the correct call }
  526. if m_isolike_io in current_settings.modeswitches then
  527. begin
  528. case inlinenumber of
  529. in_reset_typedfile:
  530. result := ccallnode.createintern('fpc_reset_typed_iso',left);
  531. in_reset_typedfile_name:
  532. result := ccallnode.createintern('fpc_reset_typed_name_iso',left);
  533. in_rewrite_typedfile:
  534. result := ccallnode.createintern('fpc_rewrite_typed_iso',left);
  535. in_rewrite_typedfile_name:
  536. result := ccallnode.createintern('fpc_rewrite_typed_name_iso',left);
  537. else
  538. internalerror(2016101501);
  539. end;
  540. end
  541. else
  542. begin
  543. if inlinenumber=in_reset_typedfile then
  544. result := ccallnode.createintern('fpc_reset_typed',left)
  545. else
  546. result := ccallnode.createintern('fpc_rewrite_typed',left);
  547. end;
  548. { make sure left doesn't get disposed, since we use it in the new call }
  549. left := nil;
  550. end;
  551. procedure maybe_convert_to_string(var n: tnode);
  552. begin
  553. { stringconstnodes are arrays of char. It's much more }
  554. { efficient to write a constant string, so convert }
  555. { either to shortstring or ansistring depending on }
  556. { length }
  557. if (n.nodetype=stringconstn) then
  558. if is_chararray(n.resultdef) then
  559. if (tstringconstnode(n).len<=255) then
  560. inserttypeconv(n,cshortstringtype)
  561. else
  562. inserttypeconv(n,getansistringdef)
  563. else if is_widechararray(n.resultdef) then
  564. inserttypeconv(n,cunicodestringtype);
  565. end;
  566. procedure get_read_write_int_func(def: tdef; out func_suffix: string; out readfunctype: tdef);
  567. var
  568. ordtype: tordtype;
  569. begin
  570. ordtype := torddef(def).ordtype;
  571. if is_oversizedint(def) then
  572. begin
  573. case ordtype of
  574. s64bit:
  575. begin
  576. func_suffix := 'int64';
  577. readfunctype:=s64inttype;
  578. end;
  579. u64bit :
  580. begin
  581. func_suffix := 'qword';
  582. readfunctype:=u64inttype;
  583. end;
  584. s32bit:
  585. begin
  586. func_suffix := 'longint';
  587. readfunctype:=s32inttype;
  588. end;
  589. u32bit :
  590. begin
  591. func_suffix := 'longword';
  592. readfunctype:=u32inttype;
  593. end;
  594. s16bit:
  595. begin
  596. func_suffix := 'smallint';
  597. readfunctype:=s16inttype;
  598. end;
  599. u16bit :
  600. begin
  601. func_suffix := 'word';
  602. readfunctype:=u16inttype;
  603. end;
  604. else
  605. internalerror(2013032602);
  606. end;
  607. end
  608. else
  609. begin
  610. case ordtype of
  611. s64bit,
  612. s32bit,
  613. s16bit,
  614. s8bit:
  615. begin
  616. func_suffix := 'sint';
  617. readfunctype := sinttype;
  618. end;
  619. u64bit,
  620. u32bit,
  621. u16bit,
  622. u8bit:
  623. begin
  624. func_suffix := 'uint';
  625. readfunctype := uinttype;
  626. end;
  627. else
  628. internalerror(2013032601);
  629. end;
  630. end;
  631. end;
  632. function Tinlinenode.handle_text_read_write(filepara,params:Ttertiarynode;var newstatement:Tnode):boolean;
  633. {Read(ln)/write(ln) for text files.}
  634. const procprefixes:array[boolean] of string[15]=('fpc_write_text_','fpc_read_text_');
  635. var error_para,is_real,special_handling,found_error,do_read:boolean;
  636. p1:Tnode;
  637. nextpara,
  638. indexpara,
  639. lenpara,
  640. para,
  641. fracpara:Tcallparanode;
  642. temp:Ttempcreatenode;
  643. readfunctype:Tdef;
  644. name:string[63];
  645. func_suffix:string[8];
  646. begin
  647. para:=Tcallparanode(params);
  648. found_error:=false;
  649. do_read:=inlinenumber in [in_read_x,in_readln_x,in_readstr_x];
  650. name:='';
  651. while assigned(para) do
  652. begin
  653. { is this parameter faulty? }
  654. error_para:=false;
  655. { is this parameter a real? }
  656. is_real:=false;
  657. { type used for the read(), this is used to check
  658. whether a temp is needed for range checking }
  659. readfunctype:=nil;
  660. { can't read/write types }
  661. if (para.left.nodetype=typen) and not(ttypenode(para.left).typedef.typ=undefineddef) then
  662. begin
  663. CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
  664. error_para := true;
  665. end;
  666. { support writeln(procvar) }
  667. if para.left.resultdef.typ=procvardef then
  668. begin
  669. p1:=ccallnode.create_procvar(nil,para.left);
  670. typecheckpass(p1);
  671. para.left:=p1;
  672. end;
  673. if inlinenumber in [in_write_x,in_writeln_x] then
  674. { prefer strings to chararrays }
  675. maybe_convert_to_string(para.left);
  676. case para.left.resultdef.typ of
  677. stringdef :
  678. name:=procprefixes[do_read]+tstringdef(para.left.resultdef).stringtypname;
  679. pointerdef :
  680. begin
  681. if (not is_pchar(para.left.resultdef)) or do_read then
  682. begin
  683. CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
  684. error_para := true;
  685. end
  686. else
  687. name:=procprefixes[do_read]+'pchar_as_pointer';
  688. end;
  689. floatdef :
  690. begin
  691. is_real:=true;
  692. if Tfloatdef(para.left.resultdef).floattype=s64currency then
  693. name := procprefixes[do_read]+'currency'
  694. else
  695. begin
  696. name := procprefixes[do_read]+'float';
  697. readfunctype:=pbestrealtype^;
  698. end;
  699. { iso pascal needs a different handler }
  700. if (m_isolike_io in current_settings.modeswitches) and do_read then
  701. name:=name+'_iso';
  702. end;
  703. enumdef:
  704. begin
  705. name:=procprefixes[do_read]+'enum';
  706. readfunctype:=s32inttype;
  707. end;
  708. orddef :
  709. begin
  710. case Torddef(para.left.resultdef).ordtype of
  711. s8bit,
  712. s16bit,
  713. s32bit,
  714. s64bit,
  715. u8bit,
  716. u16bit,
  717. u32bit,
  718. u64bit:
  719. begin
  720. get_read_write_int_func(para.left.resultdef,func_suffix,readfunctype);
  721. name := procprefixes[do_read]+func_suffix;
  722. if (m_isolike_io in current_settings.modeswitches) and do_read then
  723. name:=name+'_iso';
  724. end;
  725. uchar :
  726. begin
  727. name := procprefixes[do_read]+'char';
  728. { iso pascal needs a different handler }
  729. if (m_isolike_io in current_settings.modeswitches) and do_read then
  730. name:=name+'_iso';
  731. readfunctype:=cansichartype;
  732. end;
  733. uwidechar :
  734. begin
  735. name := procprefixes[do_read]+'widechar';
  736. readfunctype:=cwidechartype;
  737. end;
  738. scurrency:
  739. begin
  740. name := procprefixes[do_read]+'currency';
  741. { iso pascal needs a different handler }
  742. if (m_isolike_io in current_settings.modeswitches) and do_read then
  743. name:=name+'_iso';
  744. readfunctype:=s64currencytype;
  745. is_real:=true;
  746. end;
  747. pasbool1,
  748. pasbool8,
  749. pasbool16,
  750. pasbool32,
  751. pasbool64,
  752. bool8bit,
  753. bool16bit,
  754. bool32bit,
  755. bool64bit:
  756. if do_read then
  757. begin
  758. CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
  759. error_para := true;
  760. end
  761. else
  762. begin
  763. name := procprefixes[do_read]+'boolean';
  764. readfunctype:=pasbool1type;
  765. end
  766. else
  767. begin
  768. CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
  769. error_para := true;
  770. end;
  771. end;
  772. end;
  773. variantdef :
  774. name:=procprefixes[do_read]+'variant';
  775. arraydef :
  776. begin
  777. if is_chararray(para.left.resultdef) then
  778. name := procprefixes[do_read]+'pchar_as_array'
  779. else
  780. begin
  781. CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
  782. error_para := true;
  783. end
  784. end;
  785. { generic parameter }
  786. undefineddef:
  787. { don't try to generate any code for a writeln on a generic parameter }
  788. error_para:=true;
  789. else
  790. begin
  791. CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
  792. error_para := true;
  793. end;
  794. end;
  795. { iso pascal needs a different handler }
  796. if (m_isolike_io in current_settings.modeswitches) and not(do_read) then
  797. name:=name+'_iso';
  798. { check for length/fractional colon para's }
  799. fracpara:=nil;
  800. lenpara:=nil;
  801. indexpara:=nil;
  802. if assigned(para.right) and
  803. (cpf_is_colon_para in tcallparanode(para.right).callparaflags) then
  804. begin
  805. lenpara := tcallparanode(para.right);
  806. if assigned(lenpara.right) and
  807. (cpf_is_colon_para in tcallparanode(lenpara.right).callparaflags) then
  808. fracpara:=tcallparanode(lenpara.right);
  809. end;
  810. { get the next parameter now already, because we're going }
  811. { to muck around with the pointers }
  812. if assigned(fracpara) then
  813. nextpara := tcallparanode(fracpara.right)
  814. else if assigned(lenpara) then
  815. nextpara := tcallparanode(lenpara.right)
  816. else
  817. nextpara := tcallparanode(para.right);
  818. { check if a fracpara is allowed }
  819. if assigned(fracpara) and not is_real then
  820. begin
  821. CGMessagePos(fracpara.fileinfo,parser_e_illegal_colon_qualifier);
  822. error_para := true;
  823. end
  824. else if assigned(lenpara) and do_read then
  825. begin
  826. { I think this is already filtered out by parsing, but I'm not sure (JM) }
  827. CGMessagePos(lenpara.fileinfo,parser_e_illegal_colon_qualifier);
  828. error_para := true;
  829. end;
  830. { adjust found_error }
  831. found_error := found_error or error_para;
  832. if not error_para then
  833. begin
  834. special_handling:=false;
  835. { create dummy frac/len para's if necessary }
  836. if not do_read then
  837. begin
  838. { difference in default value for floats and the rest :( }
  839. if not is_real then
  840. begin
  841. if not assigned(lenpara) then
  842. begin
  843. if m_isolike_io in current_settings.modeswitches then
  844. lenpara := ccallparanode.create(
  845. cordconstnode.create(-1,s32inttype,false),nil)
  846. else
  847. lenpara := ccallparanode.create(
  848. cordconstnode.create(0,s32inttype,false),nil);
  849. end
  850. else
  851. { make sure we don't pass the successive }
  852. { parameters too. We also already have a }
  853. { reference to the next parameter in }
  854. { nextpara }
  855. lenpara.right := nil;
  856. end
  857. else
  858. begin
  859. if not assigned(lenpara) then
  860. lenpara := ccallparanode.create(
  861. cordconstnode.create(int64(-32767),s32inttype,false),nil);
  862. { also create a default fracpara if necessary }
  863. if not assigned(fracpara) then
  864. fracpara := ccallparanode.create(
  865. cordconstnode.create(int64(-1),s32inttype,false),nil);
  866. { add it to the lenpara }
  867. lenpara.right := fracpara;
  868. if not is_currency(para.left.resultdef) then
  869. begin
  870. { and add the realtype para (this also removes the link }
  871. { to any parameters coming after it) }
  872. fracpara.right := ccallparanode.create(
  873. cordconstnode.create(ord(tfloatdef(para.left.resultdef).floattype),
  874. s32inttype,true),nil);
  875. end
  876. else
  877. fracpara.right:=nil;
  878. end;
  879. if para.left.resultdef.typ=enumdef then
  880. begin
  881. {To write(ln) an enum we need a some extra parameters.}
  882. {Insert a reference to the ord2string index.}
  883. indexpara:=Ccallparanode.create(
  884. Caddrnode.create_internal(
  885. Crttinode.create(Tenumdef(para.left.resultdef),fullrtti,rdt_normal)
  886. ),
  887. nil);
  888. {Insert a reference to the typinfo.}
  889. indexpara:=Ccallparanode.create(
  890. Caddrnode.create_internal(
  891. Crttinode.create(Tenumdef(para.left.resultdef),fullrtti,rdt_ord2str)
  892. ),
  893. indexpara);
  894. {Insert a type conversion to to convert the enum to longint.}
  895. para.left:=Ctypeconvnode.create_internal(para.left,s32inttype);
  896. typecheckpass(para.left);
  897. end;
  898. end
  899. else
  900. begin
  901. {To read(ln) an enum we need a an extra parameter.}
  902. if para.left.resultdef.typ=enumdef then
  903. begin
  904. {Insert a reference to the string2ord index.}
  905. indexpara:=Ccallparanode.create(Caddrnode.create_internal(
  906. Crttinode.create(Tenumdef(para.left.resultdef),fullrtti,rdt_str2ord)
  907. ),nil);
  908. {Insert a type conversion to to convert the enum to longint.}
  909. para.left:=Ctypeconvnode.create_internal(para.left,s32inttype);
  910. typecheckpass(para.left);
  911. end;
  912. { special handling of reading small numbers, because the helpers }
  913. { expect a longint/card/bestreal var parameter. Use a temp. can't }
  914. { use functions because then the call to FPC_IOCHECK destroys }
  915. { their result before we can store it }
  916. if (readfunctype<>nil) and (para.left.resultdef<>readfunctype) then
  917. special_handling:=true;
  918. end;
  919. if special_handling then
  920. begin
  921. { since we're not going to pass the parameter as var-parameter }
  922. { to the read function, manually check whether the parameter }
  923. { can be used as var-parameter (e.g., whether it isn't a }
  924. { property) }
  925. valid_for_var(para.left,true);
  926. { create the parameter list: the temp ... }
  927. temp := ctempcreatenode.create(readfunctype,readfunctype.size,tt_persistent,false);
  928. addstatement(Tstatementnode(newstatement),temp);
  929. { ... and the file }
  930. p1 := ccallparanode.create(ctemprefnode.create(temp),
  931. filepara.getcopy);
  932. Tcallparanode(Tcallparanode(p1).right).right:=indexpara;
  933. { create the call to the helper }
  934. addstatement(Tstatementnode(newstatement),
  935. ccallnode.createintern(name,tcallparanode(p1)));
  936. { assign the result to the original var (this automatically }
  937. { takes care of range checking) }
  938. addstatement(Tstatementnode(newstatement),
  939. cassignmentnode.create(para.left,
  940. ctemprefnode.create(temp)));
  941. { release the temp location }
  942. addstatement(Tstatementnode(newstatement),ctempdeletenode.create(temp));
  943. { statement of para is used }
  944. para.left := nil;
  945. { free the enclosing tcallparanode, but not the }
  946. { parameters coming after it }
  947. para.right := nil;
  948. para.free;
  949. end
  950. else
  951. { read of non s/u-8/16bit, or a write }
  952. begin
  953. { add the filepara to the current parameter }
  954. para.right := filepara.getcopy;
  955. {Add the lenpara and the indexpara(s) (fracpara and realtype are
  956. already linked with the lenpara if necessary).}
  957. if indexpara=nil then
  958. Tcallparanode(para.right).right:=lenpara
  959. else
  960. begin
  961. if lenpara=nil then
  962. Tcallparanode(para.right).right:=indexpara
  963. else
  964. begin
  965. Tcallparanode(para.right).right:=lenpara;
  966. lenpara.right:=indexpara;
  967. end;
  968. { indexpara.right:=lenpara;}
  969. end;
  970. { in case of writing a chararray, add whether it's zero-based }
  971. if para.left.resultdef.typ=arraydef then
  972. para := ccallparanode.create(cordconstnode.create(
  973. ord(tarraydef(para.left.resultdef).lowrange=0),pasbool1type,false),para)
  974. else
  975. { in case of reading an ansistring pass a codepage argument }
  976. if do_read and is_ansistring(para.left.resultdef) then
  977. para:=ccallparanode.create(cordconstnode.create(
  978. getparaencoding(para.left.resultdef),u16inttype,true),para);
  979. { create the call statement }
  980. addstatement(Tstatementnode(newstatement),
  981. ccallnode.createintern(name,para));
  982. end
  983. end
  984. else
  985. { error_para = true }
  986. begin
  987. { free the parameter, since it isn't referenced anywhere anymore }
  988. para.right := nil;
  989. para.free;
  990. if assigned(lenpara) then
  991. begin
  992. lenpara.right := nil;
  993. lenpara.free;
  994. end;
  995. if assigned(fracpara) then
  996. begin
  997. fracpara.right := nil;
  998. fracpara.free;
  999. end;
  1000. end;
  1001. { process next parameter }
  1002. para := nextpara;
  1003. end;
  1004. { if no error, add the write(ln)/read(ln) end calls }
  1005. if not found_error then
  1006. begin
  1007. case inlinenumber of
  1008. in_read_x,
  1009. in_readstr_x:
  1010. name:='fpc_read_end';
  1011. in_write_x,
  1012. in_writestr_x:
  1013. name:='fpc_write_end';
  1014. in_readln_x:
  1015. begin
  1016. name:='fpc_readln_end';
  1017. if m_isolike_io in current_settings.modeswitches then
  1018. name:=name+'_iso';
  1019. end;
  1020. in_writeln_x:
  1021. name:='fpc_writeln_end';
  1022. else
  1023. internalerror(2019050516);
  1024. end;
  1025. addstatement(Tstatementnode(newstatement),ccallnode.createintern(name,filepara.getcopy));
  1026. end;
  1027. handle_text_read_write:=found_error;
  1028. end;
  1029. function Tinlinenode.handle_typed_read_write(filepara,params:Ttertiarynode;var newstatement:Tnode):boolean;
  1030. {Read/write for typed files.}
  1031. const procprefixes:array[boolean,boolean] of string[19]=(('fpc_typed_write','fpc_typed_read'),
  1032. ('fpc_typed_write','fpc_typed_read_iso'));
  1033. procnamesdisplay:array[boolean,boolean] of string[8] = (('Write','Read'),('WriteStr','ReadStr'));
  1034. var found_error,do_read,is_rwstr:boolean;
  1035. para,nextpara:Tcallparanode;
  1036. p1:Tnode;
  1037. temp:Ttempcreatenode;
  1038. begin
  1039. found_error:=false;
  1040. para:=Tcallparanode(params);
  1041. do_read:=inlinenumber in [in_read_x,in_readln_x,in_readstr_x];
  1042. is_rwstr := inlinenumber in [in_readstr_x,in_writestr_x];
  1043. temp:=nil;
  1044. { add the typesize to the filepara }
  1045. if filepara.resultdef.typ=filedef then
  1046. filepara.right := ccallparanode.create(cordconstnode.create(
  1047. tfiledef(filepara.resultdef).typedfiledef.size,s32inttype,true),nil);
  1048. { check for "no parameters" (you need at least one extra para for typed files) }
  1049. if not assigned(para) then
  1050. begin
  1051. CGMessage1(parser_e_wrong_parameter_size,procnamesdisplay[is_rwstr,do_read]);
  1052. found_error := true;
  1053. end;
  1054. { process all parameters }
  1055. while assigned(para) do
  1056. begin
  1057. { check if valid parameter }
  1058. if para.left.nodetype=typen then
  1059. begin
  1060. CGMessagePos(para.left.fileinfo,type_e_cant_read_write_type);
  1061. found_error := true;
  1062. end;
  1063. { support writeln(procvar) }
  1064. if (para.left.resultdef.typ=procvardef) then
  1065. begin
  1066. p1:=ccallnode.create_procvar(nil,para.left);
  1067. typecheckpass(p1);
  1068. para.left:=p1;
  1069. end;
  1070. if filepara.resultdef.typ=filedef then
  1071. inserttypeconv(para.left,tfiledef(filepara.resultdef).typedfiledef);
  1072. if assigned(para.right) and
  1073. (cpf_is_colon_para in tcallparanode(para.right).callparaflags) then
  1074. begin
  1075. CGMessagePos(para.right.fileinfo,parser_e_illegal_colon_qualifier);
  1076. { skip all colon para's }
  1077. nextpara := tcallparanode(tcallparanode(para.right).right);
  1078. while assigned(nextpara) and (cpf_is_colon_para in nextpara.callparaflags) do
  1079. nextpara := tcallparanode(nextpara.right);
  1080. found_error := true;
  1081. end
  1082. else
  1083. { get next parameter }
  1084. nextpara := tcallparanode(para.right);
  1085. { When we have a call, we have a problem: you can't pass the }
  1086. { result of a call as a formal const parameter. Solution: }
  1087. { assign the result to a temp and pass this temp as parameter }
  1088. { This is not very efficient, but write(typedfile,x) is }
  1089. { already slow by itself anyway (no buffering) (JM) }
  1090. { Actually, thge same goes for every non-simple expression }
  1091. { (such as an addition, ...) -> put everything but load nodes }
  1092. { into temps (JM) }
  1093. { of course, this must only be allowed for writes!!! (JM) }
  1094. if not(do_read) and (para.left.nodetype <> loadn) then
  1095. begin
  1096. { create temp for result }
  1097. temp := ctempcreatenode.create(para.left.resultdef,
  1098. para.left.resultdef.size,tt_persistent,false);
  1099. addstatement(Tstatementnode(newstatement),temp);
  1100. { assign result to temp }
  1101. addstatement(Tstatementnode(newstatement),
  1102. cassignmentnode.create(ctemprefnode.create(temp),
  1103. para.left));
  1104. { replace (reused) paranode with temp }
  1105. para.left := ctemprefnode.create(temp);
  1106. end;
  1107. { add fileparameter }
  1108. para.right := filepara.getcopy;
  1109. { create call statment }
  1110. { since the parameters are in the correct order, we have to insert }
  1111. { the statements always at the end of the current block }
  1112. addstatement(Tstatementnode(newstatement),
  1113. Ccallnode.createintern(procprefixes[m_isolike_io in current_settings.modeswitches,do_read],para
  1114. ));
  1115. { if we used a temp, free it }
  1116. if para.left.nodetype = temprefn then
  1117. addstatement(Tstatementnode(newstatement),ctempdeletenode.create(temp));
  1118. { process next parameter }
  1119. para := nextpara;
  1120. end;
  1121. handle_typed_read_write:=found_error;
  1122. end;
  1123. function tinlinenode.handle_read_write: tnode;
  1124. var
  1125. filepara,
  1126. nextpara,
  1127. params : tcallparanode;
  1128. newstatement : tstatementnode;
  1129. newblock : tblocknode;
  1130. filetemp : Ttempcreatenode;
  1131. name : string[31];
  1132. textsym : ttypesym;
  1133. is_typed,
  1134. do_read,
  1135. is_rwstr,
  1136. found_error : boolean;
  1137. begin
  1138. filepara := nil;
  1139. is_typed := false;
  1140. filetemp := nil;
  1141. do_read := inlinenumber in [in_read_x,in_readln_x,in_readstr_x];
  1142. is_rwstr := inlinenumber in [in_readstr_x,in_writestr_x];
  1143. { if we fail, we can quickly exit this way. We must generate something }
  1144. { instead of the inline node, because firstpass will bomb with an }
  1145. { internalerror if it encounters a read/write }
  1146. result := cerrornode.create;
  1147. { reverse the parameters (needed to get the colon parameters in the }
  1148. { correct order when processing write(ln) }
  1149. reverseparameters(tcallparanode(left));
  1150. if is_rwstr then
  1151. begin
  1152. filepara := tcallparanode(left);
  1153. { needs at least two parameters: source/dest string + min. 1 value }
  1154. if not(assigned(filepara)) or
  1155. not(assigned(filepara.right)) then
  1156. begin
  1157. CGMessagePos1(fileinfo,parser_e_wrong_parameter_size,'ReadStr/WriteStr');
  1158. exit;
  1159. end
  1160. else if (filepara.resultdef.typ <> stringdef) then
  1161. begin
  1162. { convert chararray to string, or give an appropriate error message }
  1163. { (if you want to optimize to use shortstring, keep in mind that }
  1164. { readstr internally always uses ansistring, and to account for }
  1165. { chararrays with > 255 characters) }
  1166. inserttypeconv(filepara.left,getansistringdef);
  1167. filepara.resultdef:=filepara.left.resultdef;
  1168. if codegenerror then
  1169. exit;
  1170. end
  1171. end
  1172. else if assigned(left) then
  1173. begin
  1174. { check if we have a file parameter and if yes, what kind it is }
  1175. filepara := tcallparanode(left);
  1176. if (filepara.resultdef.typ=filedef) then
  1177. begin
  1178. if (tfiledef(filepara.resultdef).filetyp=ft_untyped) then
  1179. begin
  1180. CGMessagePos(fileinfo,type_e_no_read_write_for_untyped_file);
  1181. exit;
  1182. end
  1183. else
  1184. begin
  1185. if (tfiledef(filepara.resultdef).filetyp=ft_typed) then
  1186. begin
  1187. if (inlinenumber in [in_readln_x,in_writeln_x]) then
  1188. begin
  1189. CGMessagePos(fileinfo,type_e_no_readln_writeln_for_typed_file);
  1190. exit;
  1191. end;
  1192. is_typed := true;
  1193. end
  1194. end;
  1195. end
  1196. else
  1197. filepara := nil;
  1198. end;
  1199. { create a blocknode in which the successive write/read statements will be }
  1200. { put, since they belong together. Also create a dummy statement already to }
  1201. { make inserting of additional statements easier }
  1202. newblock:=internalstatements(newstatement);
  1203. if is_rwstr then
  1204. begin
  1205. { create a dummy temp text file that will be used to cache the
  1206. readstr/writestr state. Can't use a global variable in the system
  1207. unit because these can be nested (in case of parameters to
  1208. writestr that are function calls to functions that also call
  1209. readstr/writestr) }
  1210. textsym:=search_system_type('TEXT');
  1211. filetemp:=ctempcreatenode.create(textsym.typedef,textsym.typedef.size,tt_persistent,false);
  1212. addstatement(newstatement,filetemp);
  1213. if (do_read) then
  1214. name:='fpc_setupreadstr_'
  1215. else
  1216. name:='fpc_setupwritestr_';
  1217. name:=name+tstringdef(filepara.resultdef).stringtypname;
  1218. { the file para is a var parameter, but it is properly initialized,
  1219. so it should be actually an out parameter }
  1220. if not(do_read) then
  1221. set_varstate(filepara.left,vs_written,[]);
  1222. { remove the source/destination string parameter from the }
  1223. { parameter chain }
  1224. left:=filepara.right;
  1225. filepara.right:=ccallparanode.create(ctemprefnode.create(filetemp),nil);
  1226. { in case of a writestr() to an ansistring, also pass the string's
  1227. code page }
  1228. if not do_read and
  1229. is_ansistring(filepara.left.resultdef) then
  1230. filepara:=ccallparanode.create(genintconstnode(tstringdef(filepara.left.resultdef).encoding),filepara);
  1231. { pass the temp text file and the source/destination string to the
  1232. setup routine, which will store the string's address in the
  1233. textrec }
  1234. addstatement(newstatement,ccallnode.createintern(name,filepara));
  1235. filepara:=ccallparanode.create(ctemprefnode.create(filetemp),nil);
  1236. end
  1237. { if we don't have a filepara, create one containing the default }
  1238. else if not assigned(filepara) then
  1239. begin
  1240. { since the input/output variables are threadvars loading them into
  1241. a temp once is faster. Create a temp which will hold a pointer to the file }
  1242. filetemp := ctempcreatenode.create(voidpointertype,voidpointertype.size,tt_persistent,true);
  1243. addstatement(newstatement,filetemp);
  1244. { make sure the resultdef of the temp (and as such of the }
  1245. { temprefs coming after it) is set (necessary because the }
  1246. { temprefs will be part of the filepara, of which we need }
  1247. { the resultdef later on and temprefs can only be }
  1248. { typecheckpassed if the resultdef of the temp is known) }
  1249. typecheckpass(tnode(filetemp));
  1250. { assign the address of the file to the temp }
  1251. if do_read then
  1252. name := 'input'
  1253. else
  1254. name := 'output';
  1255. addstatement(newstatement,
  1256. cassignmentnode.create(ctemprefnode.create(filetemp),
  1257. ccallnode.createintern('fpc_get_'+name,nil)));
  1258. { create a new fileparameter as follows: file_type(temp^) }
  1259. { (so that we pass the value and not the address of the temp }
  1260. { to the read/write routine) }
  1261. textsym:=search_system_type('TEXT');
  1262. filepara := ccallparanode.create(ctypeconvnode.create_internal(
  1263. cderefnode.create(ctemprefnode.create(filetemp)),textsym.typedef),nil);
  1264. end
  1265. else
  1266. { remove filepara from the parameter chain }
  1267. begin
  1268. left := filepara.right;
  1269. filepara.right := nil;
  1270. { the file para is a var parameter, but it must be valid already }
  1271. set_varstate(filepara.left,vs_readwritten,[vsf_must_be_valid]);
  1272. { check if we should make a temp to store the result of a complex }
  1273. { expression (better heuristics, anyone?) (JM) }
  1274. if (filepara.left.nodetype <> loadn) then
  1275. begin
  1276. { create a temp which will hold a pointer to the file }
  1277. filetemp := ctempcreatenode.create(voidpointertype,voidpointertype.size,tt_persistent,true);
  1278. { add it to the statements }
  1279. addstatement(newstatement,filetemp);
  1280. { make sure the resultdef of the temp (and as such of the }
  1281. { temprefs coming after it) is set (necessary because the }
  1282. { temprefs will be part of the filepara, of which we need }
  1283. { the resultdef later on and temprefs can only be }
  1284. { typecheckpassed if the resultdef of the temp is known) }
  1285. typecheckpass(tnode(filetemp));
  1286. { assign the address of the file to the temp }
  1287. addstatement(newstatement,
  1288. cassignmentnode.create(ctemprefnode.create(filetemp),
  1289. caddrnode.create_internal(filepara.left)));
  1290. typecheckpass(newstatement.left);
  1291. { create a new fileparameter as follows: file_type(temp^) }
  1292. { (so that we pass the value and not the address of the temp }
  1293. { to the read/write routine) }
  1294. nextpara := ccallparanode.create(ctypeconvnode.create_internal(
  1295. cderefnode.create(ctemprefnode.create(filetemp)),filepara.left.resultdef),nil);
  1296. { replace the old file para with the new one }
  1297. filepara.left := nil;
  1298. filepara.free;
  1299. filepara := nextpara;
  1300. end;
  1301. end;
  1302. { the resultdef of the filepara must be set since it's }
  1303. { used below }
  1304. filepara.get_paratype;
  1305. { now, filepara is nowhere referenced anymore, so we can safely dispose it }
  1306. { if something goes wrong or at the end of the procedure }
  1307. { we're going to reuse the paranodes, so make sure they don't get freed }
  1308. { twice }
  1309. params:=Tcallparanode(left);
  1310. left := nil;
  1311. if is_typed then
  1312. found_error:=handle_typed_read_write(filepara,Ttertiarynode(params),tnode(newstatement))
  1313. else
  1314. found_error:=handle_text_read_write(filepara,Ttertiarynode(params),tnode(newstatement));
  1315. { free the file parameter (it's copied inside the handle_*_read_write methods) }
  1316. filepara.free;
  1317. { if we found an error, simply delete the generated blocknode }
  1318. if found_error then
  1319. begin
  1320. { ensure that the tempinfo is freed correctly by destroying a
  1321. delete node for it
  1322. Note: this might happen legitimately whe parsing a generic that
  1323. passes a undefined type to Write/Read }
  1324. if assigned(filetemp) then
  1325. ctempdeletenode.create(filetemp).free;
  1326. newblock.free
  1327. end
  1328. else
  1329. begin
  1330. { deallocate the temp for the file para if we used one }
  1331. if assigned(filetemp) then
  1332. addstatement(newstatement,ctempdeletenode.create(filetemp));
  1333. { otherwise return the newly generated block of instructions, }
  1334. { but first free the errornode we generated at the beginning }
  1335. result.free;
  1336. result := newblock
  1337. end;
  1338. end;
  1339. function get_val_int_func(def: tdef): string;
  1340. var
  1341. ordtype: tordtype;
  1342. begin
  1343. ordtype := torddef(def).ordtype;
  1344. if not (ordtype in [s64bit,u64bit,s32bit,u32bit,s16bit,u16bit,s8bit,u8bit]) then
  1345. internalerror(2013032603);
  1346. if is_oversizedint(def) then
  1347. begin
  1348. case ordtype of
  1349. s64bit: exit('int64');
  1350. u64bit: exit('qword');
  1351. s32bit: exit('longint');
  1352. u32bit: exit('longword');
  1353. s16bit: exit('smallint');
  1354. u16bit: exit('word');
  1355. else
  1356. internalerror(2013032604);
  1357. end;
  1358. end
  1359. else
  1360. begin
  1361. case ordtype of
  1362. s64bit,s32bit,s16bit,s8bit: exit('sint');
  1363. u64bit,u32bit,u16bit,u8bit: exit('uint');
  1364. else
  1365. internalerror(2013032604);
  1366. end;
  1367. end;
  1368. internalerror(2013032605);
  1369. end;
  1370. function tinlinenode.handle_val: tnode;
  1371. var
  1372. procname,
  1373. suffix : string[31];
  1374. sourcepara,
  1375. destpara,
  1376. codepara,
  1377. sizepara,
  1378. newparas : tcallparanode;
  1379. orgcode,tc : tnode;
  1380. newstatement : tstatementnode;
  1381. newblock : tblocknode;
  1382. tempcode : ttempcreatenode;
  1383. valsinttype : tdef;
  1384. begin
  1385. { for easy exiting if something goes wrong }
  1386. result := cerrornode.create;
  1387. { check the amount of parameters }
  1388. if not(assigned(left)) or
  1389. not(assigned(tcallparanode(left).right)) then
  1390. begin
  1391. CGMessage1(parser_e_wrong_parameter_size,'Val');
  1392. exit;
  1393. end;
  1394. suffix:='';
  1395. { in case we are in a generic definition, we cannot
  1396. do all checks, the parameters might be type parameters }
  1397. if df_generic in current_procinfo.procdef.defoptions then
  1398. begin
  1399. result.Free;
  1400. result:=nil;
  1401. resultdef:=voidtype;
  1402. exit;
  1403. end;
  1404. { retrieve the ValSInt type }
  1405. valsinttype:=search_system_type('VALSINT').typedef;
  1406. { reverse parameters for easier processing }
  1407. reverseparameters(tcallparanode(left));
  1408. { get the parameters }
  1409. tempcode := nil;
  1410. orgcode := nil;
  1411. sizepara := nil;
  1412. sourcepara := tcallparanode(left);
  1413. destpara := tcallparanode(sourcepara.right);
  1414. codepara := tcallparanode(destpara.right);
  1415. { check if codepara is valid }
  1416. if assigned(codepara) and
  1417. (
  1418. not is_integer(codepara.resultdef)
  1419. {$ifndef cpu64bitaddr}
  1420. or is_64bitint(codepara.resultdef)
  1421. {$endif not cpu64bitaddr}
  1422. ) then
  1423. begin
  1424. CGMessagePos1(codepara.fileinfo,type_e_integer_expr_expected,codepara.resultdef.typename);
  1425. exit;
  1426. end;
  1427. { check if dest para is valid }
  1428. if not is_integer(destpara.resultdef) and
  1429. not is_currency(destpara.resultdef) and
  1430. not(destpara.resultdef.typ in [floatdef,enumdef]) then
  1431. begin
  1432. CGMessagePos(destpara.fileinfo,type_e_integer_or_real_expr_expected);
  1433. exit;
  1434. end;
  1435. { we're going to reuse the exisiting para's, so make sure they }
  1436. { won't be disposed }
  1437. left := nil;
  1438. { create the blocknode which will hold the generated statements + }
  1439. { an initial dummy statement }
  1440. newblock:=internalstatements(newstatement);
  1441. { do we need a temp for code? Yes, if no code specified, or if }
  1442. { code is not a valsinttype sized parameter (we already checked }
  1443. { whether the code para, if specified, was an orddef) }
  1444. if not assigned(codepara) or
  1445. (codepara.resultdef.size<>valsinttype.size) then
  1446. begin
  1447. tempcode := ctempcreatenode.create(valsinttype,valsinttype.size,tt_persistent,false);
  1448. addstatement(newstatement,tempcode);
  1449. { set the resultdef of the temp (needed to be able to get }
  1450. { the resultdef of the tempref used in the new code para) }
  1451. typecheckpass(tnode(tempcode));
  1452. { create a temp codepara, but save the original code para to }
  1453. { assign the result to later on }
  1454. if assigned(codepara) then
  1455. begin
  1456. orgcode := codepara.left;
  1457. codepara.left := ctemprefnode.create(tempcode);
  1458. end
  1459. else
  1460. codepara := ccallparanode.create(ctemprefnode.create(tempcode),nil);
  1461. { we need its resultdef later on }
  1462. codepara.get_paratype;
  1463. end
  1464. else if (torddef(codepara.resultdef).ordtype <> torddef(valsinttype).ordtype) then
  1465. { because code is a var parameter, it must match types exactly }
  1466. { however, since it will return values >= 0, both signed and }
  1467. { and unsigned ints of the same size are fine. Since the formal }
  1468. { code para type is sinttype, insert a typecoversion to sint for }
  1469. { unsigned para's }
  1470. begin
  1471. codepara.left := ctypeconvnode.create_internal(codepara.left,valsinttype);
  1472. { make it explicit, oterwise you may get a nonsense range }
  1473. { check error if the cardinal already contained a value }
  1474. { > $7fffffff }
  1475. codepara.get_paratype;
  1476. end;
  1477. { create the procedure name }
  1478. procname := 'fpc_val_';
  1479. case destpara.resultdef.typ of
  1480. orddef:
  1481. begin
  1482. case torddef(destpara.resultdef).ordtype of
  1483. s8bit,s16bit,s32bit,s64bit,
  1484. u8bit,u16bit,u32bit,u64bit:
  1485. begin
  1486. suffix := get_val_int_func(destpara.resultdef) + '_';
  1487. { we also need a destsize para in the case of sint }
  1488. if suffix = 'sint_' then
  1489. sizepara := ccallparanode.create(cordconstnode.create
  1490. (destpara.resultdef.size,s32inttype,true),nil);
  1491. end;
  1492. scurrency: suffix := 'currency_';
  1493. else
  1494. internalerror(200304225);
  1495. end;
  1496. end;
  1497. floatdef:
  1498. suffix:='real_';
  1499. enumdef:
  1500. begin
  1501. suffix:='enum_';
  1502. sizepara:=Ccallparanode.create(Caddrnode.create_internal(
  1503. Crttinode.create(Tenumdef(destpara.resultdef),fullrtti,rdt_str2ord)
  1504. ),nil);
  1505. end;
  1506. else
  1507. internalerror(2019050515);
  1508. end;
  1509. procname := procname + suffix;
  1510. { play a trick to have tcallnode handle invalid source parameters: }
  1511. { the shortstring-longint val routine by default }
  1512. if (sourcepara.resultdef.typ = stringdef) then
  1513. procname := procname + tstringdef(sourcepara.resultdef).stringtypname
  1514. { zero-based arrays (of char) can be implicitely converted to ansistring, but don't do
  1515. so if not needed because the array is too short }
  1516. else if is_zero_based_array(sourcepara.resultdef) and (sourcepara.resultdef.size>255) then
  1517. procname := procname + 'ansistr'
  1518. else
  1519. procname := procname + 'shortstr';
  1520. { set up the correct parameters for the call: the code para... }
  1521. newparas := codepara;
  1522. { and the source para }
  1523. codepara.right := sourcepara;
  1524. { sizepara either contains nil if none is needed (which is ok, since }
  1525. { then the next statement severes any possible links with other paras }
  1526. { that sourcepara may have) or it contains the necessary size para and }
  1527. { its right field is nil }
  1528. sourcepara.right := sizepara;
  1529. { create the call and assign the result to dest (val helpers are functions).
  1530. Use a trick to prevent a type size mismatch warning to be generated by the
  1531. assignment node. First convert implicitly to the resultdef. This will insert
  1532. the range check. The Second conversion is done explicitly to hide the implicit conversion
  1533. for the assignment node and therefor preventing the warning (PFV)
  1534. The implicit conversion is avoided for enums because implicit conversion between
  1535. longint (which is what fpc_val_enum_shortstr returns) and enumerations is not
  1536. possible. (DM).
  1537. The implicit conversion is also avoided for COMP type if it is handled by FPU (x86)
  1538. to prevent warning about automatic type conversion. }
  1539. if (destpara.resultdef.typ=enumdef) or
  1540. ((destpara.resultdef.typ=floatdef) and (tfloatdef(destpara.resultdef).floattype=s64comp))
  1541. then
  1542. tc:=ccallnode.createintern(procname,newparas)
  1543. else
  1544. tc:=ctypeconvnode.create(ccallnode.createintern(procname,newparas),destpara.left.resultdef);
  1545. addstatement(newstatement,cassignmentnode.create(
  1546. destpara.left,ctypeconvnode.create_internal(tc,destpara.left.resultdef)));
  1547. { dispose of the enclosing paranode of the destination }
  1548. destpara.left := nil;
  1549. destpara.right := nil;
  1550. destpara.free;
  1551. { check if we used a temp for code and whether we have to store }
  1552. { it to the real code parameter }
  1553. if assigned(orgcode) then
  1554. addstatement(newstatement,cassignmentnode.create(
  1555. orgcode,
  1556. ctypeconvnode.create_internal(
  1557. ctemprefnode.create(tempcode),orgcode.resultdef)));
  1558. { release the temp if we allocated one }
  1559. if assigned(tempcode) then
  1560. addstatement(newstatement,ctempdeletenode.create(tempcode));
  1561. { free the errornode }
  1562. result.free;
  1563. { and return it }
  1564. result := newblock;
  1565. end;
  1566. function tinlinenode.handle_setlength: tnode;
  1567. var
  1568. def: tdef;
  1569. destppn,
  1570. paras: tnode;
  1571. newstatement: tstatementnode;
  1572. ppn: tcallparanode;
  1573. counter,
  1574. dims: longint;
  1575. isarray: boolean;
  1576. begin
  1577. { for easy exiting if something goes wrong }
  1578. result:=cerrornode.create;
  1579. resultdef:=voidtype;
  1580. paras:=left;
  1581. dims:=0;
  1582. if assigned(paras) then
  1583. begin
  1584. { check type of lengths }
  1585. ppn:=tcallparanode(paras);
  1586. while assigned(ppn.right) do
  1587. begin
  1588. set_varstate(ppn.left,vs_read,[vsf_must_be_valid]);
  1589. inserttypeconv(ppn.left,sinttype);
  1590. inc(dims);
  1591. ppn:=tcallparanode(ppn.right);
  1592. end;
  1593. end
  1594. else
  1595. internalerror(2013112912);
  1596. if dims=0 then
  1597. begin
  1598. CGMessage1(parser_e_wrong_parameter_size,'SetLength');
  1599. exit;
  1600. end;
  1601. { last param must be var }
  1602. destppn:=ppn.left;
  1603. valid_for_var(destppn,true);
  1604. set_varstate(destppn,vs_written,[vsf_must_be_valid,vsf_use_hints,vsf_use_hint_for_string_result]);
  1605. { first param must be a string or dynamic array ...}
  1606. isarray:=is_dynamic_array(destppn.resultdef);
  1607. if not((destppn.resultdef.typ=stringdef) or
  1608. isarray) then
  1609. begin
  1610. { possibly generic involved? }
  1611. if df_generic in current_procinfo.procdef.defoptions then
  1612. result:=internalstatements(newstatement)
  1613. else
  1614. CGMessage(type_e_mismatch);
  1615. exit;
  1616. end;
  1617. { only dynamic arrays accept more dimensions }
  1618. if (dims>1) then
  1619. begin
  1620. if (not isarray) then
  1621. CGMessage(type_e_mismatch)
  1622. else
  1623. begin
  1624. { check if the amount of dimensions is valid }
  1625. def:=tarraydef(destppn.resultdef).elementdef;
  1626. counter:=dims;
  1627. while counter > 1 do
  1628. begin
  1629. if not(is_dynamic_array(def)) then
  1630. begin
  1631. CGMessage1(parser_e_wrong_parameter_size,'SetLength');
  1632. break;
  1633. end;
  1634. dec(counter);
  1635. def:=tarraydef(def).elementdef;
  1636. end;
  1637. end;
  1638. end;
  1639. result.free;
  1640. result:=nil;
  1641. end;
  1642. function tinlinenode.handle_copy: tnode;
  1643. procedure do_error(typemismatch:boolean;func:string;fi:tfileposinfo);
  1644. procedure write_dynarray_copy;
  1645. begin
  1646. MessagePos1(fileinfo,sym_e_param_list,'Copy(Dynamic Array;'+sizesinttype.typename+'=`<low>`;'+sizesinttype.typename+'=`<length>`);');
  1647. end;
  1648. begin
  1649. if typemismatch then
  1650. CGMessagePos(fi,type_e_mismatch)
  1651. else
  1652. CGMessagePos1(fi,parser_e_wrong_parameter_size,'Copy');
  1653. if func='' then
  1654. begin
  1655. write_system_parameter_lists('fpc_shortstr_copy');
  1656. write_system_parameter_lists('fpc_char_copy');
  1657. write_system_parameter_lists('fpc_unicodestr_copy');
  1658. if tf_winlikewidestring in target_info.flags then
  1659. write_system_parameter_lists('fpc_widestr_copy');
  1660. write_system_parameter_lists('fpc_ansistr_copy');
  1661. write_dynarray_copy;
  1662. end
  1663. else if func='fpc_dynarray_copy' then
  1664. write_dynarray_copy
  1665. else
  1666. write_system_parameter_lists(func);
  1667. end;
  1668. var
  1669. paras : tnode;
  1670. ppn : tcallparanode;
  1671. paradef : tdef;
  1672. counter : integer;
  1673. minargs,
  1674. maxargs : longint;
  1675. func : string;
  1676. begin
  1677. if not assigned(left) then
  1678. begin
  1679. do_error(false,'',fileinfo);
  1680. exit(cerrornode.create);
  1681. end;
  1682. result:=nil;
  1683. { determine copy function to use based on the first argument,
  1684. also count the number of arguments in this loop }
  1685. counter:=1;
  1686. paras:=left;
  1687. ppn:=tcallparanode(paras);
  1688. while assigned(ppn.right) do
  1689. begin
  1690. inc(counter);
  1691. set_varstate(ppn.left,vs_read,[vsf_must_be_valid]);
  1692. ppn:=tcallparanode(ppn.right);
  1693. end;
  1694. set_varstate(ppn.left,vs_read,[vsf_must_be_valid]);
  1695. paradef:=ppn.left.resultdef;
  1696. { the string variants all require 2 or 3 args, only the array one allows less }
  1697. minargs:=2;
  1698. maxargs:=3;
  1699. func:='';
  1700. if is_ansistring(paradef) then
  1701. begin
  1702. // set resultdef to argument def
  1703. resultdef:=paradef;
  1704. func:='fpc_ansistr_copy';
  1705. end
  1706. else if (is_chararray(paradef) and (paradef.size>255)) or
  1707. ((cs_refcountedstrings in current_settings.localswitches) and is_pchar(paradef)) then
  1708. begin
  1709. // set resultdef to ansistring type since result will be in ansistring codepage
  1710. resultdef:=getansistringdef;
  1711. func:='fpc_ansistr_copy';
  1712. end
  1713. else if is_widestring(paradef) then
  1714. begin
  1715. resultdef:=cwidestringtype;
  1716. func:='fpc_widestr_copy';
  1717. end
  1718. else if is_unicodestring(paradef) or
  1719. is_widechararray(paradef) or
  1720. is_pwidechar(paradef) then
  1721. begin
  1722. resultdef:=cunicodestringtype;
  1723. func:='fpc_unicodestr_copy';
  1724. end
  1725. else
  1726. if is_char(paradef) then
  1727. begin
  1728. resultdef:=cshortstringtype;
  1729. func:='fpc_char_copy';
  1730. end
  1731. else
  1732. if is_dynamic_array(paradef) then
  1733. begin
  1734. minargs:=1;
  1735. resultdef:=paradef;
  1736. func:='fpc_dynarray_copy';
  1737. end
  1738. else if counter in [2..3] then
  1739. begin
  1740. resultdef:=cshortstringtype;
  1741. func:='fpc_shortstr_copy';
  1742. end
  1743. else if counter<=maxargs then
  1744. begin
  1745. do_error(true,'',ppn.left.fileinfo);
  1746. exit(cerrornode.create);
  1747. end;
  1748. if (counter<minargs) or (counter>maxargs) then
  1749. begin
  1750. do_error(false,func,fileinfo);
  1751. exit(cerrornode.create);
  1752. end;
  1753. end;
  1754. {$maxfpuregisters 0}
  1755. function getpi : bestreal;
  1756. begin
  1757. {$ifdef x86}
  1758. { x86 has pi in hardware }
  1759. result:=pi;
  1760. {$else x86}
  1761. {$ifdef cpuextended}
  1762. result:=MathPiExtended.Value;
  1763. {$else cpuextended}
  1764. result:=MathPi.Value;
  1765. {$endif cpuextended}
  1766. {$endif x86}
  1767. end;
  1768. function tinlinenode.simplify(forinline : boolean): tnode;
  1769. function do_lowhigh(def:tdef) : tnode;
  1770. var
  1771. v : tconstexprint;
  1772. enum : tenumsym;
  1773. hp : tnode;
  1774. i : integer;
  1775. begin
  1776. case def.typ of
  1777. orddef:
  1778. begin
  1779. set_varstate(left,vs_read,[]);
  1780. if inlinenumber=in_low_x then
  1781. v:=torddef(def).low
  1782. else
  1783. v:=torddef(def).high;
  1784. hp:=cordconstnode.create(v,def,true);
  1785. typecheckpass(hp);
  1786. do_lowhigh:=hp;
  1787. end;
  1788. enumdef:
  1789. begin
  1790. set_varstate(left,vs_read,[]);
  1791. if inlinenumber=in_high_x then
  1792. v:=tenumdef(def).maxval
  1793. else
  1794. v:=tenumdef(def).minval;
  1795. enum:=nil;
  1796. for i := 0 to tenumdef(def).symtable.SymList.Count - 1 do
  1797. if tenumsym(tenumdef(def).symtable.SymList[i]).value=v then
  1798. begin
  1799. enum:=tenumsym(tenumdef(def).symtable.SymList[i]);
  1800. break;
  1801. end;
  1802. if not assigned(enum) then
  1803. internalerror(309993)
  1804. else
  1805. hp:=genenumnode(enum);
  1806. do_lowhigh:=hp;
  1807. end;
  1808. else
  1809. internalerror(87);
  1810. end;
  1811. end;
  1812. function getconstrealvalue : bestreal;
  1813. begin
  1814. case left.nodetype of
  1815. ordconstn:
  1816. getconstrealvalue:=tordconstnode(left).value;
  1817. realconstn:
  1818. getconstrealvalue:=trealconstnode(left).value_real;
  1819. else
  1820. internalerror(309992);
  1821. end;
  1822. end;
  1823. procedure setconstrealvalue(r : bestreal);
  1824. begin
  1825. result:=crealconstnode.create(r,pbestrealtype^);
  1826. end;
  1827. function handle_ln_const(r : bestreal) : tnode;
  1828. begin
  1829. if r<=0.0 then
  1830. if floating_point_range_check_error then
  1831. begin
  1832. result:=crealconstnode.create(0,pbestrealtype^);
  1833. CGMessage(type_e_wrong_math_argument)
  1834. end
  1835. else
  1836. begin
  1837. if r=0.0 then
  1838. result:=crealconstnode.create(MathNegInf.Value,pbestrealtype^)
  1839. else
  1840. result:=crealconstnode.create(MathQNaN.Value,pbestrealtype^)
  1841. end
  1842. else
  1843. result:=crealconstnode.create(ln(r),pbestrealtype^)
  1844. end;
  1845. function handle_sqrt_const(r : bestreal) : tnode;
  1846. begin
  1847. if r<0.0 then
  1848. if floating_point_range_check_error then
  1849. begin
  1850. result:=crealconstnode.create(0,pbestrealtype^);
  1851. CGMessage(type_e_wrong_math_argument)
  1852. end
  1853. else
  1854. result:=crealconstnode.create(MathQNaN.Value,pbestrealtype^)
  1855. else
  1856. result:=crealconstnode.create(sqrt(r),pbestrealtype^)
  1857. end;
  1858. function handle_const_sar : tnode;
  1859. var
  1860. vl,vl2 : TConstExprInt;
  1861. bits,shift: integer;
  1862. mask : qword;
  1863. def : tdef;
  1864. begin
  1865. result:=nil;
  1866. if (left.nodetype=ordconstn) or ((left.nodetype=callparan) and (tcallparanode(left).left.nodetype=ordconstn)) then
  1867. begin
  1868. if (left.nodetype=callparan) and
  1869. assigned(tcallparanode(left).right) then
  1870. begin
  1871. vl:=tordconstnode(tcallparanode(left).left).value;
  1872. if forinline then
  1873. case resultdef.size of
  1874. 1,2,4:
  1875. vl:=vl and byte($1f);
  1876. 8:
  1877. vl:=vl and byte($3f);
  1878. else
  1879. internalerror(2013122302);
  1880. end;
  1881. if (tcallparanode(tcallparanode(left).right).left.nodetype=ordconstn) then
  1882. begin
  1883. def:=tcallparanode(tcallparanode(left).right).left.resultdef;
  1884. vl2:=tordconstnode(tcallparanode(tcallparanode(left).right).left).value;
  1885. end
  1886. else if vl=0 then
  1887. begin
  1888. result:=tcallparanode(tcallparanode(left).right).left;
  1889. tcallparanode(tcallparanode(left).right).left:=nil;
  1890. exit;
  1891. end
  1892. else
  1893. exit;
  1894. end
  1895. else
  1896. begin
  1897. def:=left.resultdef;
  1898. vl:=1;
  1899. vl2:=tordconstnode(left).value;
  1900. end;
  1901. bits:=def.size*8;
  1902. shift:=vl.svalue and (bits-1);
  1903. case bits of
  1904. 8:
  1905. mask:=$ff;
  1906. 16:
  1907. mask:=$ffff;
  1908. 32:
  1909. mask:=$ffffffff;
  1910. 64:
  1911. mask:=qword($ffffffffffffffff);
  1912. else
  1913. mask:=qword(1 shl bits)-1;
  1914. end;
  1915. {$push}
  1916. {$r-,q-}
  1917. if shift=0 then
  1918. result:=cordconstnode.create(vl2.svalue,def,false)
  1919. else if vl2.svalue<0 then
  1920. result:=cordconstnode.create(((vl2.svalue shr shift) or (mask shl (bits-shift))) and mask,def,false)
  1921. else
  1922. result:=cordconstnode.create((vl2.svalue shr shift) and mask,def,false);
  1923. {$pop}
  1924. end
  1925. else if (left.nodetype=callparan) and assigned(tcallparanode(left).right) and
  1926. (tcallparanode(tcallparanode(left).right).left.nodetype=ordconstn) then
  1927. begin
  1928. def:=tcallparanode(tcallparanode(left).right).left.resultdef;
  1929. vl2:=tordconstnode(tcallparanode(tcallparanode(left).right).left).value;
  1930. { sar(0,x) is 0 }
  1931. { sar32(ffffffff,x) is ffffffff, etc. }
  1932. if ((vl2=0) or
  1933. ((resultdef.size=1) and (shortint(vl2.svalue)=-1)) or
  1934. ((resultdef.size=2) and (smallint(vl2.svalue)=-1)) or
  1935. ((resultdef.size=4) and (longint(vl2.svalue)=-1)) or
  1936. ((resultdef.size=8) and (int64(vl2.svalue)=-1))) and
  1937. ((cs_opt_level4 in current_settings.optimizerswitches) or
  1938. not might_have_sideeffects(tcallparanode(left).left)) then
  1939. begin
  1940. if vl2=0 then
  1941. result:=cordconstnode.create(0,resultdef,true)
  1942. else
  1943. result:=cordconstnode.create(-1,resultdef,true);
  1944. end;
  1945. end;
  1946. end;
  1947. function handle_const_rox : tnode;
  1948. var
  1949. vl,vl2 : TConstExprInt;
  1950. bits,shift: integer;
  1951. def : tdef;
  1952. begin
  1953. result:=nil;
  1954. if (left.nodetype=ordconstn) or ((left.nodetype=callparan) and (tcallparanode(left).left.nodetype=ordconstn)) then
  1955. begin
  1956. if (left.nodetype=callparan) and
  1957. assigned(tcallparanode(left).right) then
  1958. begin
  1959. vl:=tordconstnode(tcallparanode(left).left).value;
  1960. if forinline then
  1961. case resultdef.size of
  1962. { unlike shifts, for rotates, when masking out the higher bits
  1963. of the rotate count, we go all the way down to byte, because
  1964. it doesn't matter, it produces the same result, since it's a rotate }
  1965. 1:
  1966. vl:=vl and byte($07);
  1967. 2:
  1968. vl:=vl and byte($0f);
  1969. 4:
  1970. vl:=vl and byte($1f);
  1971. 8:
  1972. vl:=vl and byte($3f);
  1973. else
  1974. internalerror(2013122302);
  1975. end;
  1976. if (tcallparanode(tcallparanode(left).right).left.nodetype=ordconstn) then
  1977. begin
  1978. def:=tcallparanode(tcallparanode(left).right).left.resultdef;
  1979. vl2:=tordconstnode(tcallparanode(tcallparanode(left).right).left).value;
  1980. end
  1981. else if vl=0 then
  1982. begin
  1983. result:=tcallparanode(tcallparanode(left).right).left;
  1984. tcallparanode(tcallparanode(left).right).left:=nil;
  1985. exit;
  1986. end
  1987. else
  1988. exit;
  1989. end
  1990. else
  1991. begin
  1992. def:=left.resultdef;
  1993. vl:=1;
  1994. vl2:=tordconstnode(left).value;
  1995. end;
  1996. bits:=def.size*8;
  1997. shift:=vl.svalue and (bits-1);
  1998. {$push}
  1999. {$r-,q-}
  2000. if shift=0 then
  2001. result:=cordconstnode.create(vl2.svalue,def,false)
  2002. else
  2003. case inlinenumber of
  2004. in_ror_x,in_ror_x_y:
  2005. case def.size of
  2006. 1:
  2007. result:=cordconstnode.create(RorByte(Byte(vl2.svalue),shift),def,false);
  2008. 2:
  2009. result:=cordconstnode.create(RorWord(Word(vl2.svalue),shift),def,false);
  2010. 4:
  2011. result:=cordconstnode.create(RorDWord(DWord(vl2.svalue),shift),def,false);
  2012. 8:
  2013. result:=cordconstnode.create(RorQWord(QWord(vl2.svalue),shift),def,false);
  2014. else
  2015. internalerror(2011061903);
  2016. end;
  2017. in_rol_x,in_rol_x_y:
  2018. case def.size of
  2019. 1:
  2020. result:=cordconstnode.create(RolByte(Byte(vl2.svalue),shift),def,false);
  2021. 2:
  2022. result:=cordconstnode.create(RolWord(Word(vl2.svalue),shift),def,false);
  2023. 4:
  2024. result:=cordconstnode.create(RolDWord(DWord(vl2.svalue),shift),def,false);
  2025. 8:
  2026. result:=cordconstnode.create(RolQWord(QWord(vl2.svalue),shift),def,false);
  2027. else
  2028. internalerror(2011061902);
  2029. end;
  2030. else
  2031. internalerror(2011061901);
  2032. end;
  2033. {$pop}
  2034. end
  2035. else if (left.nodetype=callparan) and assigned(tcallparanode(left).right) and
  2036. (tcallparanode(tcallparanode(left).right).left.nodetype=ordconstn) then
  2037. begin
  2038. def:=tcallparanode(tcallparanode(left).right).left.resultdef;
  2039. vl2:=tordconstnode(tcallparanode(tcallparanode(left).right).left).value;
  2040. { rol/ror are unsigned operations, so cut off upper bits }
  2041. case resultdef.size of
  2042. 1:
  2043. vl2:=vl2 and byte($ff);
  2044. 2:
  2045. vl2:=vl2 and word($ffff);
  2046. 4:
  2047. vl2:=vl2 and dword($ffffffff);
  2048. 8:
  2049. vl2:=vl2 and qword($ffffffffffffffff);
  2050. else
  2051. internalerror(2017050101);
  2052. end;
  2053. { rol(0,x) and ror(0,x) are 0 }
  2054. { rol32(ffffffff,x) and ror32(ffffffff,x) are ffffffff, etc. }
  2055. if ((vl2=0) or
  2056. ((resultdef.size=1) and (vl2=$ff)) or
  2057. ((resultdef.size=2) and (vl2=$ffff)) or
  2058. ((resultdef.size=4) and (vl2=$ffffffff)) or
  2059. ((resultdef.size=8) and (vl2.uvalue=qword($ffffffffffffffff)))) and
  2060. ((cs_opt_level4 in current_settings.optimizerswitches) or
  2061. not might_have_sideeffects(tcallparanode(left).left)) then
  2062. result:=cordconstnode.create(vl2,resultdef,true);
  2063. end;
  2064. end;
  2065. var
  2066. hp : tnode;
  2067. vl,vl2 : TConstExprInt;
  2068. vr : bestreal;
  2069. begin { simplify }
  2070. result:=nil;
  2071. { handle intern constant functions in separate case }
  2072. if nf_inlineconst in flags then
  2073. begin
  2074. { no parameters? }
  2075. if not assigned(left) then
  2076. internalerror(200501231)
  2077. else
  2078. begin
  2079. vl:=0;
  2080. vl2:=0; { second parameter Ex: ptr(vl,vl2) }
  2081. case left.nodetype of
  2082. realconstn :
  2083. begin
  2084. { Real functions are all handled with internproc below }
  2085. CGMessage1(type_e_integer_expr_expected,left.resultdef.typename)
  2086. end;
  2087. ordconstn :
  2088. vl:=tordconstnode(left).value;
  2089. callparan :
  2090. begin
  2091. { both exists, else it was not generated }
  2092. vl:=tordconstnode(tcallparanode(left).left).value;
  2093. vl2:=tordconstnode(tcallparanode(tcallparanode(left).right).left).value;
  2094. end;
  2095. else
  2096. CGMessage(parser_e_illegal_expression);
  2097. end;
  2098. case inlinenumber of
  2099. in_const_abs :
  2100. if vl.signed then
  2101. hp:=create_simplified_ord_const(abs(vl.svalue),resultdef,forinline,false)
  2102. else
  2103. hp:=create_simplified_ord_const(vl.uvalue,resultdef,forinline,false);
  2104. in_const_sqr:
  2105. if vl.signed then
  2106. hp:=create_simplified_ord_const(sqr(vl.svalue),resultdef,forinline,false)
  2107. else
  2108. hp:=create_simplified_ord_const(sqr(vl.uvalue),resultdef,forinline,false);
  2109. in_const_odd :
  2110. hp:=cordconstnode.create(qword(odd(int64(vl))),pasbool1type,true);
  2111. in_const_swap_word :
  2112. hp:=cordconstnode.create((vl and $ff) shl 8+(vl shr 8),left.resultdef,true);
  2113. in_const_swap_long :
  2114. hp:=cordconstnode.create((vl and $ffff) shl 16+(vl shr 16),left.resultdef,true);
  2115. in_const_swap_qword :
  2116. hp:=cordconstnode.create((vl and $ffffffff) shl 32+(vl shr 32),left.resultdef,true);
  2117. in_const_ptr:
  2118. begin
  2119. {Don't construct pointers from negative values.}
  2120. if (vl.signed and (vl.svalue<0)) or (vl2.signed and (vl2.svalue<0)) then
  2121. cgmessage(parser_e_range_check_error);
  2122. {$if defined(i8086)}
  2123. hp:=cpointerconstnode.create((vl2.uvalue shl 16)+vl.uvalue,voidfarpointertype);
  2124. {$elseif defined(i386)}
  2125. hp:=cpointerconstnode.create((vl2.uvalue shl 4)+vl.uvalue,voidnearfspointertype);
  2126. {$else}
  2127. hp:=cpointerconstnode.create((vl2.uvalue shl 4)+vl.uvalue,voidpointertype);
  2128. {$endif}
  2129. end;
  2130. in_const_eh_return_data_regno:
  2131. begin
  2132. vl:=eh_return_data_regno(vl.svalue);
  2133. if vl=-1 then
  2134. CGMessagePos(left.fileinfo,type_e_range_check_error_bounds);
  2135. hp:=genintconstnode(vl);
  2136. end;
  2137. else
  2138. internalerror(88);
  2139. end;
  2140. end;
  2141. if hp=nil then
  2142. hp:=cerrornode.create;
  2143. result:=hp;
  2144. end
  2145. else
  2146. begin
  2147. case inlinenumber of
  2148. in_lo_long,
  2149. in_hi_long,
  2150. in_lo_qword,
  2151. in_hi_qword,
  2152. in_lo_word,
  2153. in_hi_word :
  2154. begin
  2155. if left.nodetype=ordconstn then
  2156. begin
  2157. case inlinenumber of
  2158. in_lo_word :
  2159. result:=cordconstnode.create(tordconstnode(left).value and $ff,u8inttype,true);
  2160. in_hi_word :
  2161. result:=cordconstnode.create(tordconstnode(left).value shr 8,u8inttype,true);
  2162. in_lo_long :
  2163. result:=cordconstnode.create(tordconstnode(left).value and $ffff,u16inttype,true);
  2164. in_hi_long :
  2165. result:=cordconstnode.create(tordconstnode(left).value shr 16,u16inttype,true);
  2166. in_lo_qword :
  2167. result:=cordconstnode.create(tordconstnode(left).value and $ffffffff,u32inttype,true);
  2168. in_hi_qword :
  2169. result:=cordconstnode.create(tordconstnode(left).value shr 32,u32inttype,true);
  2170. else
  2171. internalerror(2019050514);
  2172. end;
  2173. end;
  2174. end;
  2175. in_ord_x:
  2176. begin
  2177. case left.resultdef.typ of
  2178. orddef :
  2179. begin
  2180. case torddef(left.resultdef).ordtype of
  2181. pasbool1,
  2182. pasbool8,
  2183. uchar:
  2184. begin
  2185. { change to byte() }
  2186. result:=ctypeconvnode.create_internal(left,u8inttype);
  2187. left:=nil;
  2188. end;
  2189. pasbool16,
  2190. uwidechar :
  2191. begin
  2192. { change to word() }
  2193. result:=ctypeconvnode.create_internal(left,u16inttype);
  2194. left:=nil;
  2195. end;
  2196. pasbool32 :
  2197. begin
  2198. { change to dword() }
  2199. result:=ctypeconvnode.create_internal(left,u32inttype);
  2200. left:=nil;
  2201. end;
  2202. pasbool64 :
  2203. begin
  2204. { change to qword() }
  2205. result:=ctypeconvnode.create_internal(left,u64inttype);
  2206. left:=nil;
  2207. end;
  2208. bool8bit:
  2209. begin
  2210. { change to shortint() }
  2211. result:=ctypeconvnode.create_internal(left,s8inttype);
  2212. left:=nil;
  2213. end;
  2214. bool16bit :
  2215. begin
  2216. { change to smallint() }
  2217. result:=ctypeconvnode.create_internal(left,s16inttype);
  2218. left:=nil;
  2219. end;
  2220. bool32bit :
  2221. begin
  2222. { change to longint() }
  2223. result:=ctypeconvnode.create_internal(left,s32inttype);
  2224. left:=nil;
  2225. end;
  2226. bool64bit :
  2227. begin
  2228. { change to int64() }
  2229. result:=ctypeconvnode.create_internal(left,s64inttype);
  2230. left:=nil;
  2231. end;
  2232. uvoid :
  2233. CGMessage1(type_e_ordinal_expr_expected,left.resultdef.typename);
  2234. else
  2235. begin
  2236. { all other orddef need no transformation }
  2237. result:=left;
  2238. left:=nil;
  2239. end;
  2240. end;
  2241. end;
  2242. enumdef :
  2243. begin
  2244. result:=ctypeconvnode.create_internal(left,s32inttype);
  2245. left:=nil;
  2246. end;
  2247. pointerdef :
  2248. begin
  2249. if m_mac in current_settings.modeswitches then
  2250. begin
  2251. result:=ctypeconvnode.create_internal(left,ptruinttype);
  2252. left:=nil;
  2253. end
  2254. end;
  2255. else
  2256. internalerror(2019050513);
  2257. end;
  2258. (*
  2259. if (left.nodetype=ordconstn) then
  2260. begin
  2261. result:=cordconstnode.create(
  2262. tordconstnode(left).value,sinttype,true);
  2263. end
  2264. else if (m_mac in current_settings.modeswitches) and
  2265. (left.ndoetype=pointerconstn) then
  2266. result:=cordconstnode.create(
  2267. tpointerconstnode(left).value,ptruinttype,true);
  2268. *)
  2269. end;
  2270. in_chr_byte:
  2271. begin
  2272. { convert to explicit char() }
  2273. result:=ctypeconvnode.create_internal(left,cansichartype);
  2274. left:=nil;
  2275. end;
  2276. in_length_x:
  2277. begin
  2278. case left.resultdef.typ of
  2279. stringdef :
  2280. begin
  2281. if (left.nodetype=stringconstn) then
  2282. begin
  2283. result:=cordconstnode.create(
  2284. tstringconstnode(left).len,sinttype,true);
  2285. end;
  2286. end;
  2287. orddef :
  2288. begin
  2289. { length of char is always one }
  2290. if is_char(left.resultdef) or
  2291. is_widechar(left.resultdef) then
  2292. begin
  2293. result:=cordconstnode.create(1,sinttype,false);
  2294. end
  2295. end;
  2296. arraydef :
  2297. begin
  2298. if (left.nodetype=stringconstn) then
  2299. begin
  2300. result:=cordconstnode.create(
  2301. tstringconstnode(left).len,sinttype,true);
  2302. end
  2303. else if not is_open_array(left.resultdef) and
  2304. not is_array_of_const(left.resultdef) and
  2305. not is_dynamic_array(left.resultdef) then
  2306. result:=cordconstnode.create(tarraydef(left.resultdef).highrange-
  2307. tarraydef(left.resultdef).lowrange+1,
  2308. sinttype,true);
  2309. end;
  2310. else
  2311. ;
  2312. end;
  2313. end;
  2314. in_assigned_x:
  2315. begin
  2316. if is_constnode(tcallparanode(left).left) or
  2317. (tcallparanode(left).left.nodetype = pointerconstn) then
  2318. begin
  2319. { let an add node figure it out }
  2320. result:=caddnode.create(unequaln,tcallparanode(left).left,cnilnode.create);
  2321. tcallparanode(left).left := nil;
  2322. end;
  2323. end;
  2324. in_pred_x,
  2325. in_succ_x:
  2326. begin
  2327. case left.nodetype of
  2328. ordconstn:
  2329. begin
  2330. if inlinenumber=in_succ_x then
  2331. vl:=tordconstnode(left).value+1
  2332. else
  2333. vl:=tordconstnode(left).value-1;
  2334. if is_integer(left.resultdef) then
  2335. { the type of the original integer constant is irrelevant,
  2336. it should be automatically adapted to the new value
  2337. (except when inlining) }
  2338. result:=create_simplified_ord_const(vl,resultdef,forinline,cs_check_range in localswitches)
  2339. else
  2340. { check the range for enums, chars, booleans }
  2341. result:=cordconstnode.create(vl,left.resultdef,not(nf_internal in flags));
  2342. result.flags:=result.flags+(flags*[nf_internal]);
  2343. end;
  2344. addn,
  2345. subn:
  2346. begin
  2347. { fold succ/pred in child add/sub nodes with a constant if possible:
  2348. - no overflow/range checking
  2349. - equal types
  2350. }
  2351. if ([cs_check_overflow,cs_check_range]*current_settings.localswitches)=[] then
  2352. begin
  2353. if inlinenumber=in_succ_x then
  2354. vl:=1
  2355. else
  2356. vl:=-1;
  2357. if (taddnode(left).left.nodetype=ordconstn) and equal_defs(resultdef,taddnode(left).left.resultdef) then
  2358. begin
  2359. tordconstnode(taddnode(left).left).value:=tordconstnode(taddnode(left).left).value+vl;
  2360. result:=left;
  2361. left:=nil;
  2362. end
  2363. else if (taddnode(left).right.nodetype=ordconstn) and equal_defs(resultdef,taddnode(left).right.resultdef) then
  2364. begin
  2365. if left.nodetype=subn then
  2366. tordconstnode(taddnode(left).right).value:=tordconstnode(taddnode(left).right).value-vl
  2367. else
  2368. tordconstnode(taddnode(left).right).value:=tordconstnode(taddnode(left).right).value+vl;
  2369. result:=left;
  2370. left:=nil;
  2371. end;
  2372. end;
  2373. end;
  2374. else
  2375. ;
  2376. end;
  2377. end;
  2378. in_low_x,
  2379. in_high_x:
  2380. begin
  2381. case left.resultdef.typ of
  2382. orddef,
  2383. enumdef:
  2384. begin
  2385. result:=do_lowhigh(left.resultdef);
  2386. end;
  2387. setdef:
  2388. begin
  2389. result:=do_lowhigh(tsetdef(left.resultdef).elementdef);
  2390. end;
  2391. arraydef:
  2392. begin
  2393. if (inlinenumber=in_low_x) then
  2394. begin
  2395. result:=cordconstnode.create(int64(tarraydef(
  2396. left.resultdef).lowrange),tarraydef(left.resultdef).rangedef,true);
  2397. end
  2398. else if not is_open_array(left.resultdef) and
  2399. not is_array_of_const(left.resultdef) and
  2400. not is_dynamic_array(left.resultdef) then
  2401. result:=cordconstnode.create(int64(tarraydef(left.resultdef).highrange),
  2402. tarraydef(left.resultdef).rangedef,true);
  2403. end;
  2404. stringdef:
  2405. begin
  2406. if inlinenumber=in_low_x then
  2407. begin
  2408. if is_dynamicstring(left.resultdef) and
  2409. not(cs_zerobasedstrings in current_settings.localswitches) then
  2410. result:=cordconstnode.create(1,u8inttype,false)
  2411. else
  2412. result:=cordconstnode.create(0,u8inttype,false);
  2413. end
  2414. else if not is_dynamicstring(left.resultdef) then
  2415. result:=cordconstnode.create(tstringdef(left.resultdef).len,u8inttype,true)
  2416. end;
  2417. undefineddef:
  2418. begin
  2419. result:=cordconstnode.create(0,u8inttype,false);
  2420. end;
  2421. errordef:
  2422. ;
  2423. else
  2424. internalerror(2019050512);
  2425. end;
  2426. end;
  2427. in_exp_real :
  2428. begin
  2429. if left.nodetype in [ordconstn,realconstn] then
  2430. begin
  2431. result:=crealconstnode.create(exp(getconstrealvalue),pbestrealtype^);
  2432. if (trealconstnode(result).value_real=MathInf.Value) and
  2433. floating_point_range_check_error then
  2434. begin
  2435. result:=crealconstnode.create(0,pbestrealtype^);
  2436. CGMessage(parser_e_range_check_error);
  2437. end;
  2438. end
  2439. end;
  2440. in_trunc_real :
  2441. begin
  2442. if left.nodetype in [ordconstn,realconstn] then
  2443. begin
  2444. vr:=getconstrealvalue;
  2445. if (vr>=9223372036854775807.99) or (vr<=-9223372036854775808.0) then
  2446. begin
  2447. message3(type_e_range_check_error_bounds,realtostr(vr),'-9223372036854775808.0','9223372036854775807.99..');
  2448. result:=cordconstnode.create(1,s64inttype,false)
  2449. end
  2450. else
  2451. result:=cordconstnode.create(trunc(vr),s64inttype,true)
  2452. end
  2453. end;
  2454. in_round_real :
  2455. begin
  2456. { can't evaluate while inlining, may depend on fpu setting }
  2457. if (not forinline) and
  2458. (left.nodetype in [ordconstn,realconstn]) then
  2459. begin
  2460. vr:=getconstrealvalue;
  2461. if (vr>=9223372036854775807.5) or (vr<=-9223372036854775808.5) then
  2462. begin
  2463. message3(type_e_range_check_error_bounds,realtostr(vr),'-9223372036854775808.49..','9223372036854775807.49..');
  2464. result:=cordconstnode.create(1,s64inttype,false)
  2465. end
  2466. else
  2467. result:=cordconstnode.create(round(vr),s64inttype,true)
  2468. end
  2469. end;
  2470. in_frac_real :
  2471. begin
  2472. if left.nodetype in [ordconstn,realconstn] then
  2473. setconstrealvalue(frac(getconstrealvalue))
  2474. end;
  2475. in_int_real :
  2476. begin
  2477. if left.nodetype in [ordconstn,realconstn] then
  2478. setconstrealvalue(int(getconstrealvalue));
  2479. end;
  2480. in_pi_real :
  2481. begin
  2482. if block_type=bt_const then
  2483. setconstrealvalue(getpi)
  2484. end;
  2485. in_cos_real :
  2486. begin
  2487. if left.nodetype in [ordconstn,realconstn] then
  2488. setconstrealvalue(cos(getconstrealvalue))
  2489. end;
  2490. in_sin_real :
  2491. begin
  2492. if left.nodetype in [ordconstn,realconstn] then
  2493. setconstrealvalue(sin(getconstrealvalue))
  2494. end;
  2495. in_arctan_real :
  2496. begin
  2497. if left.nodetype in [ordconstn,realconstn] then
  2498. setconstrealvalue(arctan(getconstrealvalue))
  2499. end;
  2500. in_abs_real :
  2501. begin
  2502. if left.nodetype in [ordconstn,realconstn] then
  2503. setconstrealvalue(abs(getconstrealvalue))
  2504. end;
  2505. in_abs_long:
  2506. begin
  2507. if left.nodetype=ordconstn then
  2508. begin
  2509. if tordconstnode(left).value<0 then
  2510. result:=cordconstnode.create((-tordconstnode(left).value),resultdef,false)
  2511. else
  2512. result:=cordconstnode.create((tordconstnode(left).value),resultdef,false);
  2513. end
  2514. end;
  2515. in_sqr_real :
  2516. begin
  2517. if left.nodetype in [ordconstn,realconstn] then
  2518. setconstrealvalue(sqr(getconstrealvalue))
  2519. end;
  2520. in_sqrt_real :
  2521. begin
  2522. if left.nodetype in [ordconstn,realconstn] then
  2523. result:=handle_sqrt_const(getconstrealvalue);
  2524. end;
  2525. in_ln_real :
  2526. begin
  2527. if left.nodetype in [ordconstn,realconstn] then
  2528. result:=handle_ln_const(getconstrealvalue);
  2529. end;
  2530. in_assert_x_y :
  2531. begin
  2532. if not(cs_do_assertion in current_settings.localswitches) then
  2533. { we need a valid node, so insert a nothingn }
  2534. result:=cnothingnode.create;
  2535. end;
  2536. in_sar_x,
  2537. in_sar_x_y :
  2538. begin
  2539. result:=handle_const_sar;
  2540. end;
  2541. in_rol_x,
  2542. in_rol_x_y,
  2543. in_ror_x,
  2544. in_ror_x_y :
  2545. result:=handle_const_rox;
  2546. in_bsf_x:
  2547. begin
  2548. if left.nodetype=ordconstn then
  2549. begin
  2550. case left.resultdef.size of
  2551. 1:
  2552. result:=cordconstnode.create(BsfByte(Byte(tordconstnode(left).value.uvalue)),resultdef,false);
  2553. 2:
  2554. result:=cordconstnode.create(BsfWord(Word(tordconstnode(left).value.uvalue)),resultdef,false);
  2555. 4:
  2556. result:=cordconstnode.create(BsfDWord(DWord(tordconstnode(left).value.uvalue)),resultdef,false);
  2557. 8:
  2558. result:=cordconstnode.create(BsfQWord(QWord(tordconstnode(left).value.uvalue)),resultdef,false);
  2559. else
  2560. internalerror(2017042401);
  2561. end;
  2562. end;
  2563. end;
  2564. in_bsr_x :
  2565. begin
  2566. if left.nodetype=ordconstn then
  2567. begin
  2568. case left.resultdef.size of
  2569. 1:
  2570. result:=cordconstnode.create(BsrByte(Byte(tordconstnode(left).value.uvalue)),resultdef,false);
  2571. 2:
  2572. result:=cordconstnode.create(BsrWord(Word(tordconstnode(left).value.uvalue)),resultdef,false);
  2573. 4:
  2574. result:=cordconstnode.create(BsrDWord(DWord(tordconstnode(left).value.uvalue)),resultdef,false);
  2575. 8:
  2576. result:=cordconstnode.create(BsrQWord(QWord(tordconstnode(left).value.uvalue)),resultdef,false);
  2577. else
  2578. internalerror(2017042401);
  2579. end;
  2580. end;
  2581. end;
  2582. in_popcnt_x :
  2583. begin
  2584. if left.nodetype=ordconstn then
  2585. begin
  2586. result:=cordconstnode.create(PopCnt(tordconstnode(left).value),resultdef,false);
  2587. end;
  2588. end;
  2589. else
  2590. ;
  2591. end;
  2592. end;
  2593. end;
  2594. function tinlinenode.pass_typecheck:tnode;
  2595. procedure setfloatresultdef;
  2596. var
  2597. hnode: tnode;
  2598. begin
  2599. { System unit declares internal functions like this:
  2600. function foo(x: valreal): valreal; [internproc: number];
  2601. Calls to such functions are initially processed by callnode,
  2602. which typechecks the arguments, possibly inserting conversion to valreal.
  2603. To handle smaller types without excess precision, we need to remove
  2604. these extra typecasts. }
  2605. if (left.nodetype=typeconvn) and
  2606. (ttypeconvnode(left).left.resultdef.typ=floatdef) and
  2607. (left.flags*[nf_explicit,nf_internal]=[]) and
  2608. (tfloatdef(ttypeconvnode(left).left.resultdef).floattype in [s32real,s64real,s80real,sc80real,s128real]) then
  2609. begin
  2610. hnode:=ttypeconvnode(left).left;
  2611. ttypeconvnode(left).left:=nil;
  2612. left.free;
  2613. left:=hnode;
  2614. resultdef:=left.resultdef;
  2615. end
  2616. else if (left.resultdef.typ=floatdef) and
  2617. (tfloatdef(left.resultdef).floattype in [s32real,s64real,s80real,sc80real,s128real]) then
  2618. resultdef:=left.resultdef
  2619. else
  2620. begin
  2621. if (left.nodetype <> ordconstn) then
  2622. inserttypeconv(left,pbestrealtype^);
  2623. resultdef:=pbestrealtype^;
  2624. end;
  2625. end;
  2626. procedure handle_pack_unpack;
  2627. var
  2628. source, target, index: tcallparanode;
  2629. unpackedarraydef, packedarraydef: tarraydef;
  2630. tempindex: TConstExprInt;
  2631. begin
  2632. resultdef:=voidtype;
  2633. unpackedarraydef := nil;
  2634. packedarraydef := nil;
  2635. source := tcallparanode(left);
  2636. if (inlinenumber = in_unpack_x_y_z) then
  2637. begin
  2638. target := tcallparanode(source.right);
  2639. index := tcallparanode(target.right);
  2640. { source must be a packed array }
  2641. if not is_packed_array(source.left.resultdef) then
  2642. CGMessagePos2(source.left.fileinfo,type_e_got_expected_packed_array,'1',source.left.resultdef.typename)
  2643. else
  2644. packedarraydef := tarraydef(source.left.resultdef);
  2645. { target can be any kind of array, as long as it's not packed }
  2646. if (target.left.resultdef.typ <> arraydef) or
  2647. is_packed_array(target.left.resultdef) then
  2648. CGMessagePos2(target.left.fileinfo,type_e_got_expected_unpacked_array,'2',target.left.resultdef.typename)
  2649. else
  2650. unpackedarraydef := tarraydef(target.left.resultdef);
  2651. end
  2652. else
  2653. begin
  2654. index := tcallparanode(source.right);
  2655. target := tcallparanode(index.right);
  2656. { source can be any kind of array, as long as it's not packed }
  2657. if (source.left.resultdef.typ <> arraydef) or
  2658. is_packed_array(source.left.resultdef) then
  2659. CGMessagePos2(source.left.fileinfo,type_e_got_expected_unpacked_array,'1',source.left.resultdef.typename)
  2660. else
  2661. unpackedarraydef := tarraydef(source.left.resultdef);
  2662. { target must be a packed array }
  2663. if not is_packed_array(target.left.resultdef) then
  2664. CGMessagePos2(target.left.fileinfo,type_e_got_expected_packed_array,'3',target.left.resultdef.typename)
  2665. else
  2666. packedarraydef := tarraydef(target.left.resultdef);
  2667. end;
  2668. if assigned(unpackedarraydef) then
  2669. begin
  2670. { index must be compatible with the unpacked array's indextype }
  2671. inserttypeconv(index.left,unpackedarraydef.rangedef);
  2672. { range check at compile time if possible }
  2673. if assigned(packedarraydef) and
  2674. (index.left.nodetype = ordconstn) and
  2675. not is_special_array(unpackedarraydef) then
  2676. begin
  2677. adaptrange(unpackedarraydef,tordconstnode(index.left).value,false,false,cs_check_range in current_settings.localswitches);
  2678. tempindex := tordconstnode(index.left).value + packedarraydef.highrange-packedarraydef.lowrange;
  2679. adaptrange(unpackedarraydef,tempindex,false,false,cs_check_range in current_settings.localswitches);
  2680. end;
  2681. end;
  2682. { source array is read and must be valid }
  2683. set_varstate(source.left,vs_read,[vsf_must_be_valid]);
  2684. { target array is written }
  2685. valid_for_assignment(target.left,true);
  2686. set_varstate(target.left,vs_written,[]);
  2687. { index in the unpacked array is read and must be valid }
  2688. set_varstate(index.left,vs_read,[vsf_must_be_valid]);
  2689. { if the size of the arrays is 0 (array of empty records), }
  2690. { do nothing }
  2691. if (source.resultdef.size = 0) then
  2692. result:=cnothingnode.create;
  2693. end;
  2694. function handle_objc_encode: tnode;
  2695. var
  2696. encodedtype: ansistring;
  2697. errordef: tdef;
  2698. begin
  2699. encodedtype:='';
  2700. if not objctryencodetype(left.resultdef,encodedtype,errordef) then
  2701. Message1(type_e_objc_type_unsupported,errordef.typename);
  2702. result:=cstringconstnode.createpchar(ansistring2pchar(encodedtype),length(encodedtype),nil);
  2703. end;
  2704. var
  2705. hightree,
  2706. hp : tnode;
  2707. temp_pnode: pnode;
  2708. begin
  2709. result:=nil;
  2710. { when handling writeln "left" contains no valid address }
  2711. if assigned(left) then
  2712. begin
  2713. if left.nodetype=callparan then
  2714. tcallparanode(left).get_paratype
  2715. else
  2716. typecheckpass(left);
  2717. end;
  2718. if not(nf_inlineconst in flags) then
  2719. begin
  2720. case inlinenumber of
  2721. in_lo_long,
  2722. in_hi_long,
  2723. in_lo_qword,
  2724. in_hi_qword,
  2725. in_lo_word,
  2726. in_hi_word :
  2727. begin
  2728. { give warning for incompatibility with tp and delphi }
  2729. if (inlinenumber in [in_lo_long,in_hi_long,in_lo_qword,in_hi_qword]) and
  2730. ((m_tp7 in current_settings.modeswitches) or
  2731. (m_delphi in current_settings.modeswitches)) then
  2732. CGMessage(type_w_maybe_wrong_hi_lo);
  2733. set_varstate(left,vs_read,[vsf_must_be_valid]);
  2734. if not is_integer(left.resultdef) then
  2735. CGMessage1(type_e_integer_expr_expected,left.resultdef.typename);
  2736. case inlinenumber of
  2737. in_lo_word,
  2738. in_hi_word :
  2739. resultdef:=u8inttype;
  2740. in_lo_long,
  2741. in_hi_long :
  2742. resultdef:=u16inttype;
  2743. in_lo_qword,
  2744. in_hi_qword :
  2745. resultdef:=u32inttype;
  2746. else
  2747. ;
  2748. end;
  2749. end;
  2750. in_sizeof_x:
  2751. begin
  2752. { the constant evaluation of in_sizeof_x happens in pexpr where possible }
  2753. set_varstate(left,vs_read,[]);
  2754. if (left.resultdef.typ<>undefineddef) and
  2755. paramanager.push_high_param(vs_value,left.resultdef,current_procinfo.procdef.proccalloption) then
  2756. begin
  2757. { this should be an open array or array of const, both of
  2758. which can only be simple load nodes of parameters }
  2759. if left.nodetype<>loadn then
  2760. internalerror(2014120701);
  2761. hightree:=load_high_value_node(tparavarsym(tloadnode(left).symtableentry));
  2762. if assigned(hightree) then
  2763. begin
  2764. hp:=caddnode.create(addn,hightree,
  2765. cordconstnode.create(1,sizesinttype,false));
  2766. if (left.resultdef.typ=arraydef) then
  2767. if not is_packed_array(tarraydef(left.resultdef)) then
  2768. begin
  2769. if (tarraydef(left.resultdef).elesize<>1) then
  2770. hp:=caddnode.create(muln,hp,cordconstnode.create(tarraydef(
  2771. left.resultdef).elesize,sizesinttype,true));
  2772. end
  2773. else if (tarraydef(left.resultdef).elepackedbitsize <> 8) then
  2774. begin
  2775. { no packed open array support yet }
  2776. if (hp.nodetype <> ordconstn) then
  2777. internalerror(2006081511);
  2778. hp.free;
  2779. hp := cordconstnode.create(left.resultdef.size,sizesinttype,true);
  2780. {
  2781. hp:=
  2782. ctypeconvnode.create_explicit(sizesinttype,
  2783. cmoddivnode.create(divn,
  2784. caddnode.create(addn,
  2785. caddnode.create(muln,hp,cordconstnode.create(tarraydef(
  2786. left.resultdef).elepackedbitsize,s64inttype,true)),
  2787. cordconstnode.create(a,s64inttype,true)),
  2788. cordconstnode.create(8,s64inttype,true)),
  2789. sizesinttype);
  2790. }
  2791. end;
  2792. result:=hp;
  2793. end;
  2794. end
  2795. else
  2796. resultdef:=sizesinttype;
  2797. end;
  2798. in_typeof_x:
  2799. begin
  2800. if target_info.system in systems_managed_vm then
  2801. message(parser_e_feature_unsupported_for_vm);
  2802. typecheckpass(left);
  2803. set_varstate(left,vs_read,[]);
  2804. if (left.resultdef.typ=objectdef) and
  2805. not(oo_has_vmt in tobjectdef(left.resultdef).objectoptions) then
  2806. message(type_e_typeof_requires_vmt);
  2807. resultdef:=voidpointertype;
  2808. end;
  2809. in_ord_x:
  2810. begin
  2811. set_varstate(left,vs_read,[vsf_must_be_valid]);
  2812. case left.resultdef.typ of
  2813. orddef,
  2814. enumdef :
  2815. ;
  2816. pointerdef :
  2817. begin
  2818. if not(m_mac in current_settings.modeswitches) then
  2819. CGMessage1(type_e_ordinal_expr_expected,left.resultdef.typename);
  2820. end
  2821. else
  2822. CGMessage1(type_e_ordinal_expr_expected,left.resultdef.typename);
  2823. end;
  2824. end;
  2825. in_chr_byte:
  2826. begin
  2827. set_varstate(left,vs_read,[vsf_must_be_valid]);
  2828. end;
  2829. in_length_x:
  2830. begin
  2831. if ((left.resultdef.typ=arraydef) and
  2832. (not is_special_array(left.resultdef) or
  2833. is_open_array(left.resultdef))) or
  2834. (left.resultdef.typ=orddef) then
  2835. set_varstate(left,vs_read,[])
  2836. else
  2837. set_varstate(left,vs_read,[vsf_must_be_valid]);
  2838. case left.resultdef.typ of
  2839. variantdef:
  2840. begin
  2841. inserttypeconv(left,getansistringdef);
  2842. end;
  2843. stringdef :
  2844. begin
  2845. { we don't need string convertions here, }
  2846. { except if from widestring to ansistring }
  2847. { and vice versa (that can change the }
  2848. { length) }
  2849. if (left.nodetype=typeconvn) and
  2850. (ttypeconvnode(left).left.resultdef.typ=stringdef) and
  2851. not(is_wide_or_unicode_string(left.resultdef) xor
  2852. is_wide_or_unicode_string(ttypeconvnode(left).left.resultdef)) then
  2853. begin
  2854. hp:=ttypeconvnode(left).left;
  2855. ttypeconvnode(left).left:=nil;
  2856. left.free;
  2857. left:=hp;
  2858. end;
  2859. end;
  2860. orddef :
  2861. begin
  2862. { will be handled in simplify }
  2863. if not is_char(left.resultdef) and
  2864. not is_widechar(left.resultdef) then
  2865. CGMessage(type_e_mismatch);
  2866. end;
  2867. pointerdef :
  2868. begin
  2869. if is_pchar(left.resultdef) then
  2870. begin
  2871. hp := ccallparanode.create(left,nil);
  2872. result := ccallnode.createintern('fpc_pchar_length',hp);
  2873. { make sure the left node doesn't get disposed, since it's }
  2874. { reused in the new node (JM) }
  2875. left:=nil;
  2876. exit;
  2877. end
  2878. else if is_pwidechar(left.resultdef) then
  2879. begin
  2880. hp := ccallparanode.create(left,nil);
  2881. result := ccallnode.createintern('fpc_pwidechar_length',hp);
  2882. { make sure the left node doesn't get disposed, since it's }
  2883. { reused in the new node (JM) }
  2884. left:=nil;
  2885. exit;
  2886. end
  2887. else
  2888. CGMessage(type_e_mismatch);
  2889. end;
  2890. arraydef :
  2891. begin
  2892. if is_open_array(left.resultdef) or
  2893. is_array_of_const(left.resultdef) then
  2894. begin
  2895. hightree:=load_high_value_node(tparavarsym(tloadnode(left).symtableentry));
  2896. if assigned(hightree) then
  2897. result:=caddnode.create(addn,hightree,
  2898. cordconstnode.create(1,sinttype,false));
  2899. exit;
  2900. end
  2901. { Length() for dynamic arrays is inlined }
  2902. else
  2903. begin
  2904. { will be handled in simplify }
  2905. end;
  2906. end;
  2907. undefineddef :
  2908. begin
  2909. if not (df_generic in current_procinfo.procdef.defoptions) then
  2910. CGMessage(type_e_mismatch);
  2911. { otherwise nothing }
  2912. end;
  2913. else
  2914. CGMessage(type_e_mismatch);
  2915. end;
  2916. { shortstring return an 8 bit value as the length
  2917. is the first byte of the string }
  2918. if is_shortstring(left.resultdef) then
  2919. resultdef:=u8inttype
  2920. else
  2921. resultdef:=ossinttype;
  2922. end;
  2923. in_typeinfo_x:
  2924. begin
  2925. if target_info.system in systems_managed_vm then
  2926. message(parser_e_feature_unsupported_for_vm);
  2927. if (left.resultdef.typ=enumdef) and
  2928. (tenumdef(left.resultdef).has_jumps) then
  2929. CGMessage(type_e_no_type_info);
  2930. set_varstate(left,vs_read,[vsf_must_be_valid]);
  2931. resultdef:=voidpointertype;
  2932. end;
  2933. in_gettypekind_x:
  2934. begin
  2935. if target_info.system in systems_managed_vm then
  2936. message(parser_e_feature_unsupported_for_vm);
  2937. if (left.resultdef.typ=enumdef) and
  2938. (tenumdef(left.resultdef).has_jumps) then
  2939. CGMessage(type_e_no_type_info);
  2940. set_varstate(left,vs_read,[vsf_must_be_valid]);
  2941. resultdef:=typekindtype;
  2942. end;
  2943. in_ismanagedtype_x:
  2944. begin
  2945. if target_info.system in systems_managed_vm then
  2946. message(parser_e_feature_unsupported_for_vm);
  2947. set_varstate(left,vs_read,[vsf_must_be_valid]);
  2948. resultdef:=pasbool1type;
  2949. end;
  2950. in_assigned_x:
  2951. begin
  2952. { the parser has already made sure the expression is valid }
  2953. { in case of a complex procvar, only check the "code" pointer }
  2954. if (tcallparanode(left).left.resultdef.typ=procvardef) and
  2955. not tprocvardef(tcallparanode(left).left.resultdef).is_addressonly then
  2956. begin
  2957. inserttypeconv_explicit(tcallparanode(left).left,search_system_type('TMETHOD').typedef);
  2958. tcallparanode(left).left:=csubscriptnode.create(tsym(tabstractrecorddef(tcallparanode(left).left.resultdef).symtable.find('CODE')),tcallparanode(left).left);
  2959. tcallparanode(left).get_paratype;
  2960. end;
  2961. { Postpone conversion into addnode until firstpass, so targets
  2962. may override first_assigned and insert specific code. }
  2963. set_varstate(tcallparanode(left).left,vs_read,[vsf_must_be_valid]);
  2964. resultdef:=pasbool1type;
  2965. end;
  2966. in_ofs_x :
  2967. internalerror(2000101001);
  2968. in_seg_x :
  2969. begin
  2970. result := typecheck_seg;
  2971. end;
  2972. in_pred_x,
  2973. in_succ_x:
  2974. begin
  2975. set_varstate(left,vs_read,[vsf_must_be_valid]);
  2976. resultdef:=left.resultdef;
  2977. if is_ordinal(resultdef) or is_typeparam(resultdef) then
  2978. begin
  2979. if (resultdef.typ=enumdef) and
  2980. (tenumdef(resultdef).has_jumps) and
  2981. not(m_delphi in current_settings.modeswitches) and
  2982. not(nf_internal in flags) then
  2983. CGMessage(type_e_succ_and_pred_enums_with_assign_not_possible);
  2984. end
  2985. else
  2986. CGMessage(type_e_ordinal_expr_expected)
  2987. end;
  2988. in_copy_x:
  2989. result:=handle_copy;
  2990. in_initialize_x,
  2991. in_finalize_x:
  2992. begin
  2993. { inlined from pinline }
  2994. internalerror(200204231);
  2995. end;
  2996. in_setlength_x:
  2997. begin
  2998. result:=handle_setlength;
  2999. end;
  3000. in_inc_x,
  3001. in_dec_x:
  3002. begin
  3003. resultdef:=voidtype;
  3004. if not(df_generic in current_procinfo.procdef.defoptions) then
  3005. begin
  3006. if assigned(left) then
  3007. begin
  3008. { first param must be var }
  3009. valid_for_var(tcallparanode(left).left,true);
  3010. set_varstate(tcallparanode(left).left,vs_readwritten,[vsf_must_be_valid]);
  3011. if (left.resultdef.typ in [enumdef,pointerdef]) or
  3012. is_ordinal(left.resultdef) or
  3013. is_currency(left.resultdef) then
  3014. begin
  3015. { value of left gets changed -> must be unique }
  3016. set_unique(tcallparanode(left).left);
  3017. { two paras ? }
  3018. if assigned(tcallparanode(left).right) then
  3019. begin
  3020. if is_integer(tcallparanode(left).right.resultdef) then
  3021. begin
  3022. set_varstate(tcallparanode(tcallparanode(left).right).left,vs_read,[vsf_must_be_valid]);
  3023. { when range/overflow checking is on, we
  3024. convert this to a regular add, and for proper
  3025. checking we need the original type }
  3026. if ([cs_check_range,cs_check_overflow]*current_settings.localswitches=[]) then
  3027. if (tcallparanode(left).left.resultdef.typ=pointerdef) then
  3028. begin
  3029. { don't convert values added to pointers into the pointer types themselves,
  3030. because that will turn signed values into unsigned ones, which then
  3031. goes wrong when they have to be multiplied with the size of the elements
  3032. to which the pointer points in ncginl (mantis #17342) }
  3033. if is_signed(tcallparanode(tcallparanode(left).right).left.resultdef) then
  3034. inserttypeconv(tcallparanode(tcallparanode(left).right).left,tpointerdef(tcallparanode(left).left.resultdef).pointer_arithmetic_int_type)
  3035. else
  3036. inserttypeconv(tcallparanode(tcallparanode(left).right).left,tpointerdef(tcallparanode(left).left.resultdef).pointer_arithmetic_uint_type)
  3037. end
  3038. else if is_integer(tcallparanode(left).left.resultdef) then
  3039. inserttypeconv(tcallparanode(tcallparanode(left).right).left,tcallparanode(left).left.resultdef)
  3040. else
  3041. inserttypeconv_internal(tcallparanode(tcallparanode(left).right).left,tcallparanode(left).left.resultdef);
  3042. if assigned(tcallparanode(tcallparanode(left).right).right) then
  3043. { should be handled in the parser (JM) }
  3044. internalerror(2006020901);
  3045. end
  3046. else
  3047. CGMessagePos(tcallparanode(left).right.fileinfo,type_e_ordinal_expr_expected);
  3048. end;
  3049. end
  3050. { generic type parameter? }
  3051. else if is_typeparam(left.resultdef) then
  3052. begin
  3053. result:=cnothingnode.create;
  3054. exit;
  3055. end
  3056. else
  3057. begin
  3058. hp:=self;
  3059. if isunaryoverloaded(hp,[]) then
  3060. begin
  3061. { inc(rec) and dec(rec) assigns result value to argument }
  3062. result:=cassignmentnode.create(tcallparanode(left).left.getcopy,hp);
  3063. exit;
  3064. end
  3065. else
  3066. CGMessagePos(left.fileinfo,type_e_ordinal_expr_expected);
  3067. end;
  3068. end
  3069. else
  3070. CGMessagePos(fileinfo,type_e_mismatch);
  3071. end;
  3072. end;
  3073. in_and_assign_x_y,
  3074. in_or_assign_x_y,
  3075. in_xor_assign_x_y,
  3076. in_sar_assign_x_y,
  3077. in_shl_assign_x_y,
  3078. in_shr_assign_x_y,
  3079. in_rol_assign_x_y,
  3080. in_ror_assign_x_y:
  3081. begin
  3082. resultdef:=voidtype;
  3083. if not(df_generic in current_procinfo.procdef.defoptions) then
  3084. begin
  3085. { first parameter must exist }
  3086. if not assigned(left) or (left.nodetype<>callparan) then
  3087. internalerror(2017032501);
  3088. { second parameter must exist }
  3089. if not assigned(tcallparanode(left).right) or (tcallparanode(left).right.nodetype<>callparan) then
  3090. internalerror(2017032502);
  3091. { third parameter must NOT exist }
  3092. if assigned(tcallparanode(tcallparanode(left).right).right) then
  3093. internalerror(2017032503);
  3094. valid_for_var(tcallparanode(tcallparanode(left).right).left,true);
  3095. set_varstate(tcallparanode(tcallparanode(left).right).left,vs_readwritten,[vsf_must_be_valid]);
  3096. if is_integer(tcallparanode(left).right.resultdef) then
  3097. begin
  3098. { value of right gets changed -> must be unique }
  3099. set_unique(tcallparanode(tcallparanode(left).right).left);
  3100. if is_integer(left.resultdef) then
  3101. begin
  3102. set_varstate(tcallparanode(left).left,vs_read,[vsf_must_be_valid]);
  3103. { these nodes shouldn't be created, when range checking is on }
  3104. if [cs_check_range,cs_check_overflow]*localswitches<>[] then
  3105. internalerror(2017032701);
  3106. if inlinenumber in [in_sar_assign_x_y,in_shl_assign_x_y,in_shr_assign_x_y,in_rol_assign_x_y,in_ror_assign_x_y] then
  3107. inserttypeconv(tcallparanode(left).left,sinttype)
  3108. else
  3109. inserttypeconv(tcallparanode(left).left,tcallparanode(tcallparanode(left).right).left.resultdef);
  3110. end
  3111. else
  3112. CGMessagePos(left.fileinfo,type_e_ordinal_expr_expected);
  3113. end
  3114. { generic type parameter? }
  3115. else if is_typeparam(tcallparanode(left).right.resultdef) then
  3116. begin
  3117. result:=cnothingnode.create;
  3118. exit;
  3119. end
  3120. else
  3121. CGMessagePos(tcallparanode(left).right.fileinfo,type_e_ordinal_expr_expected);
  3122. end;
  3123. end;
  3124. in_neg_assign_x,
  3125. in_not_assign_x:
  3126. begin
  3127. resultdef:=voidtype;
  3128. if not(df_generic in current_procinfo.procdef.defoptions) then
  3129. begin
  3130. valid_for_var(left,true);
  3131. set_varstate(left,vs_readwritten,[vsf_must_be_valid]);
  3132. if is_integer(left.resultdef) then
  3133. begin
  3134. { value of left gets changed -> must be unique }
  3135. set_unique(left);
  3136. { these nodes shouldn't be created, when range checking is on }
  3137. if [cs_check_range,cs_check_overflow]*current_settings.localswitches<>[] then
  3138. internalerror(2017040703);
  3139. end
  3140. { generic type parameter? }
  3141. else if is_typeparam(left.resultdef) then
  3142. begin
  3143. result:=cnothingnode.create;
  3144. exit;
  3145. end
  3146. else
  3147. CGMessagePos(left.fileinfo,type_e_ordinal_expr_expected);
  3148. end;
  3149. end;
  3150. in_read_x,
  3151. in_readln_x,
  3152. in_readstr_x,
  3153. in_write_x,
  3154. in_writeln_x,
  3155. in_writestr_x :
  3156. begin
  3157. result := handle_read_write;
  3158. end;
  3159. in_settextbuf_file_x :
  3160. begin
  3161. if target_info.system in systems_managed_vm then
  3162. message(parser_e_feature_unsupported_for_vm);
  3163. resultdef:=voidtype;
  3164. { now we know the type of buffer }
  3165. hp:=ccallparanode.create(cordconstnode.create(
  3166. tcallparanode(left).left.resultdef.size,s32inttype,true),left);
  3167. result:=ccallnode.createintern('SETTEXTBUF',hp);
  3168. left:=nil;
  3169. end;
  3170. { the firstpass of the arg has been done in firstcalln ? }
  3171. in_reset_typedfile,
  3172. in_rewrite_typedfile,
  3173. in_reset_typedfile_name,
  3174. in_rewrite_typedfile_name :
  3175. begin
  3176. result := handle_reset_rewrite_typed;
  3177. end;
  3178. in_str_x_string :
  3179. begin
  3180. result:=handle_str;
  3181. end;
  3182. in_val_x :
  3183. begin
  3184. result:=handle_val;
  3185. end;
  3186. in_include_x_y,
  3187. in_exclude_x_y:
  3188. begin
  3189. resultdef:=voidtype;
  3190. { the parser already checks whether we have two (and exactly two) }
  3191. { parameters (JM) }
  3192. { first param must be var }
  3193. valid_for_var(tcallparanode(left).left,true);
  3194. set_varstate(tcallparanode(left).left,vs_readwritten,[vsf_must_be_valid]);
  3195. { check type }
  3196. if (left.resultdef.typ=setdef) then
  3197. begin
  3198. { insert a type conversion }
  3199. { to the type of the set elements }
  3200. set_varstate(tcallparanode(tcallparanode(left).right).left,vs_read,[vsf_must_be_valid]);
  3201. inserttypeconv(tcallparanode(tcallparanode(left).right).left,
  3202. tsetdef(left.resultdef).elementdef);
  3203. end
  3204. else
  3205. CGMessage(type_e_mismatch);
  3206. end;
  3207. in_pack_x_y_z,
  3208. in_unpack_x_y_z :
  3209. begin
  3210. handle_pack_unpack;
  3211. end;
  3212. in_slice_x:
  3213. begin
  3214. if target_info.system in systems_managed_vm then
  3215. message(parser_e_feature_unsupported_for_vm);
  3216. result:=nil;
  3217. resultdef:=tcallparanode(left).left.resultdef;
  3218. if (resultdef.typ <> arraydef) then
  3219. CGMessagePos(left.fileinfo,type_e_mismatch)
  3220. else if is_packed_array(resultdef) then
  3221. CGMessagePos2(left.fileinfo,type_e_got_expected_unpacked_array,'1',resultdef.typename);
  3222. if not(is_integer(tcallparanode(tcallparanode(left).right).left.resultdef)) then
  3223. CGMessagePos1(tcallparanode(left).right.fileinfo,
  3224. type_e_integer_expr_expected,
  3225. tcallparanode(tcallparanode(left).right).left.resultdef.typename);
  3226. end;
  3227. in_new_x:
  3228. resultdef:=left.resultdef;
  3229. in_low_x,
  3230. in_high_x:
  3231. begin
  3232. case left.resultdef.typ of
  3233. undefineddef,
  3234. orddef,
  3235. enumdef,
  3236. setdef:
  3237. ;
  3238. arraydef:
  3239. begin
  3240. if (inlinenumber=in_low_x) then
  3241. set_varstate(left,vs_read,[])
  3242. else
  3243. begin
  3244. if is_open_array(left.resultdef) or
  3245. is_array_of_const(left.resultdef) then
  3246. begin
  3247. set_varstate(left,vs_read,[]);
  3248. result:=load_high_value_node(tparavarsym(tloadnode(left).symtableentry));
  3249. end
  3250. else
  3251. begin
  3252. set_varstate(left,vs_read,[]);
  3253. resultdef:=sizesinttype;
  3254. end;
  3255. end;
  3256. end;
  3257. stringdef:
  3258. begin
  3259. if inlinenumber=in_low_x then
  3260. begin
  3261. set_varstate(left,vs_read,[]);
  3262. end
  3263. else
  3264. begin
  3265. if is_open_string(left.resultdef) then
  3266. begin
  3267. set_varstate(left,vs_read,[]);
  3268. result:=load_high_value_node(tparavarsym(tloadnode(left).symtableentry))
  3269. end
  3270. else if is_dynamicstring(left.resultdef) then
  3271. begin
  3272. result:=cinlinenode.create(in_length_x,false,left);
  3273. if cs_zerobasedstrings in current_settings.localswitches then
  3274. result:=caddnode.create(subn,result,cordconstnode.create(1,sinttype,false));
  3275. { make sure the left node doesn't get disposed, since it's }
  3276. { reused in the new node (JM) }
  3277. left:=nil;
  3278. end
  3279. end;
  3280. end;
  3281. else
  3282. CGMessage(type_e_mismatch);
  3283. end;
  3284. end;
  3285. in_exp_real,
  3286. in_frac_real,
  3287. in_int_real,
  3288. in_cos_real,
  3289. in_sin_real,
  3290. in_arctan_real,
  3291. in_ln_real :
  3292. begin
  3293. set_varstate(left,vs_read,[vsf_must_be_valid]);
  3294. { converting an int64 to double on platforms without }
  3295. { extended can cause precision loss }
  3296. if not(left.nodetype in [ordconstn,realconstn]) then
  3297. inserttypeconv(left,pbestrealtype^);
  3298. resultdef:=pbestrealtype^;
  3299. end;
  3300. in_trunc_real,
  3301. in_round_real :
  3302. begin
  3303. { on i8086, the int64 result is returned in a var param, because
  3304. it's too big to fit in a register or a pair of registers. In
  3305. that case we have 2 parameters and left.nodetype is a callparan. }
  3306. if left.nodetype = callparan then
  3307. temp_pnode := @tcallparanode(left).left
  3308. else
  3309. temp_pnode := @left;
  3310. set_varstate(temp_pnode^,vs_read,[vsf_must_be_valid]);
  3311. { for direct float rounding, no best real type cast should be necessary }
  3312. if not((temp_pnode^.resultdef.typ=floatdef) and
  3313. (tfloatdef(temp_pnode^.resultdef).floattype in [s32real,s64real,s80real,sc80real,s128real])) and
  3314. { converting an int64 to double on platforms without }
  3315. { extended can cause precision loss }
  3316. not(temp_pnode^.nodetype in [ordconstn,realconstn]) then
  3317. inserttypeconv(temp_pnode^,pbestrealtype^);
  3318. resultdef:=s64inttype;
  3319. end;
  3320. in_pi_real :
  3321. begin
  3322. resultdef:=pbestrealtype^;
  3323. end;
  3324. in_abs_long:
  3325. begin
  3326. set_varstate(left,vs_read,[vsf_must_be_valid]);
  3327. resultdef:=left.resultdef;
  3328. end;
  3329. in_abs_real,
  3330. in_sqr_real,
  3331. in_sqrt_real :
  3332. begin
  3333. set_varstate(left,vs_read,[vsf_must_be_valid]);
  3334. setfloatresultdef;
  3335. end;
  3336. {$ifdef SUPPORT_MMX}
  3337. in_mmx_pcmpeqb..in_mmx_pcmpgtw:
  3338. begin
  3339. end;
  3340. {$endif SUPPORT_MMX}
  3341. in_aligned_x,
  3342. in_unaligned_x:
  3343. begin
  3344. resultdef:=left.resultdef;
  3345. end;
  3346. in_volatile_x:
  3347. begin
  3348. resultdef:=left.resultdef;
  3349. { volatile only makes sense if the value is in memory }
  3350. make_not_regable(left,[ra_addr_regable]);
  3351. end;
  3352. in_assert_x_y :
  3353. begin
  3354. resultdef:=voidtype;
  3355. if assigned(left) then
  3356. begin
  3357. set_varstate(tcallparanode(left).left,vs_read,[vsf_must_be_valid]);
  3358. { check type }
  3359. if is_boolean(left.resultdef) or
  3360. (
  3361. (left.resultdef.typ=undefineddef) and
  3362. (df_generic in current_procinfo.procdef.defoptions)
  3363. ) then
  3364. begin
  3365. set_varstate(tcallparanode(tcallparanode(left).right).left,vs_read,[vsf_must_be_valid]);
  3366. { must always be a string }
  3367. inserttypeconv(tcallparanode(tcallparanode(left).right).left,cshortstringtype);
  3368. end
  3369. else
  3370. CGMessage1(type_e_boolean_expr_expected,left.resultdef.typename);
  3371. end
  3372. else
  3373. CGMessage(type_e_mismatch);
  3374. if (cs_do_assertion in current_settings.localswitches) then
  3375. include(current_procinfo.flags,pi_do_call);
  3376. end;
  3377. in_prefetch_var:
  3378. resultdef:=voidtype;
  3379. in_get_frame,
  3380. in_get_caller_frame,
  3381. in_get_caller_addr:
  3382. begin
  3383. resultdef:=voidpointertype;
  3384. end;
  3385. in_rol_x,
  3386. in_ror_x,
  3387. in_sar_x:
  3388. begin
  3389. set_varstate(left,vs_read,[vsf_must_be_valid]);
  3390. resultdef:=left.resultdef;
  3391. end;
  3392. in_rol_x_y,
  3393. in_ror_x_y,
  3394. in_sar_x_y:
  3395. begin
  3396. set_varstate(tcallparanode(left).left,vs_read,[vsf_must_be_valid]);
  3397. set_varstate(tcallparanode(tcallparanode(left).right).left,vs_read,[vsf_must_be_valid]);
  3398. resultdef:=tcallparanode(tcallparanode(left).right).left.resultdef;
  3399. end;
  3400. in_bsf_x,
  3401. in_bsr_x:
  3402. begin
  3403. set_varstate(left,vs_read,[vsf_must_be_valid]);
  3404. if not is_integer(left.resultdef) then
  3405. CGMessage1(type_e_integer_expr_expected,left.resultdef.typename);
  3406. if torddef(left.resultdef).ordtype in [u64bit, s64bit] then
  3407. resultdef:=u64inttype
  3408. else
  3409. resultdef:=u32inttype
  3410. end;
  3411. in_popcnt_x:
  3412. begin
  3413. set_varstate(left,vs_read,[vsf_must_be_valid]);
  3414. if not is_integer(left.resultdef) then
  3415. CGMessage1(type_e_integer_expr_expected,left.resultdef.typename);
  3416. resultdef:=left.resultdef;
  3417. end;
  3418. in_objc_selector_x:
  3419. begin
  3420. result:=cobjcselectornode.create(left);
  3421. { reused }
  3422. left:=nil;
  3423. end;
  3424. in_objc_protocol_x:
  3425. begin
  3426. result:=cobjcprotocolnode.create(left);
  3427. { reused }
  3428. left:=nil;
  3429. end;
  3430. in_objc_encode_x:
  3431. begin
  3432. result:=handle_objc_encode;
  3433. end;
  3434. in_default_x:
  3435. begin
  3436. result:=handle_default;
  3437. end;
  3438. in_box_x:
  3439. begin
  3440. result:=handle_box;
  3441. end;
  3442. in_unbox_x_y:
  3443. begin
  3444. result:=handle_unbox;
  3445. end;
  3446. in_fma_single,
  3447. in_fma_double,
  3448. in_fma_extended,
  3449. in_fma_float128:
  3450. begin
  3451. set_varstate(tcallparanode(left).left,vs_read,[vsf_must_be_valid]);
  3452. set_varstate(tcallparanode(tcallparanode(left).right).left,vs_read,[vsf_must_be_valid]);
  3453. set_varstate(tcallparanode(tcallparanode(tcallparanode(left).right).right).left,vs_read,[vsf_must_be_valid]);
  3454. resultdef:=tcallparanode(left).left.resultdef;
  3455. end;
  3456. in_delete_x_y_z:
  3457. begin
  3458. result:=handle_delete;
  3459. end;
  3460. in_insert_x_y_z:
  3461. begin
  3462. result:=handle_insert;
  3463. end;
  3464. in_concat_x:
  3465. begin
  3466. result:=handle_concat;
  3467. end;
  3468. else
  3469. result:=pass_typecheck_cpu;
  3470. end;
  3471. end;
  3472. if not assigned(result) and not
  3473. codegenerror then
  3474. result:=simplify(false);
  3475. end;
  3476. function tinlinenode.pass_typecheck_cpu : tnode;
  3477. begin
  3478. Result:=nil;
  3479. internalerror(2017110102);
  3480. end;
  3481. function tinlinenode.pass_1 : tnode;
  3482. var
  3483. hp: tnode;
  3484. shiftconst: longint;
  3485. objdef: tobjectdef;
  3486. sym : tsym;
  3487. begin
  3488. result:=nil;
  3489. { if we handle writeln; left contains no valid address }
  3490. if assigned(left) then
  3491. begin
  3492. if left.nodetype=callparan then
  3493. tcallparanode(left).firstcallparan
  3494. else
  3495. firstpass(left);
  3496. end;
  3497. { intern const should already be handled }
  3498. if nf_inlineconst in flags then
  3499. internalerror(200104044);
  3500. case inlinenumber of
  3501. in_lo_qword,
  3502. in_hi_qword,
  3503. in_lo_long,
  3504. in_hi_long,
  3505. in_lo_word,
  3506. in_hi_word:
  3507. begin
  3508. shiftconst := 0;
  3509. case inlinenumber of
  3510. in_hi_qword:
  3511. shiftconst := 32;
  3512. in_hi_long:
  3513. shiftconst := 16;
  3514. in_hi_word:
  3515. shiftconst := 8;
  3516. else
  3517. ;
  3518. end;
  3519. if shiftconst <> 0 then
  3520. result := ctypeconvnode.create_internal(cshlshrnode.create(shrn,left,
  3521. cordconstnode.create(shiftconst,sinttype,false)),resultdef)
  3522. else
  3523. result := ctypeconvnode.create_internal(left,resultdef);
  3524. left := nil;
  3525. firstpass(result);
  3526. end;
  3527. in_sizeof_x,
  3528. in_typeof_x:
  3529. begin
  3530. expectloc:=LOC_REGISTER;
  3531. case left.resultdef.typ of
  3532. objectdef,classrefdef:
  3533. begin
  3534. if left.resultdef.typ=objectdef then
  3535. begin
  3536. result:=cloadvmtaddrnode.create(left);
  3537. objdef:=tobjectdef(left.resultdef);
  3538. end
  3539. else
  3540. begin
  3541. result:=left;
  3542. objdef:=tobjectdef(tclassrefdef(left.resultdef).pointeddef);
  3543. end;
  3544. left:=nil;
  3545. if inlinenumber=in_sizeof_x then
  3546. begin
  3547. inserttypeconv_explicit(result,cpointerdef.getreusable(objdef.vmt_def));
  3548. result:=cderefnode.create(result);
  3549. result:=genloadfield(result,'VINSTANCESIZE');
  3550. end
  3551. else
  3552. inserttypeconv_explicit(result,voidpointertype);
  3553. end;
  3554. undefineddef:
  3555. ;
  3556. else
  3557. internalerror(2015122702);
  3558. end;
  3559. end;
  3560. in_length_x:
  3561. begin
  3562. result:=first_length;
  3563. end;
  3564. in_typeinfo_x:
  3565. begin
  3566. result:=caddrnode.create_internal(
  3567. crttinode.create(tstoreddef(left.resultdef),fullrtti,rdt_normal)
  3568. );
  3569. end;
  3570. in_gettypekind_x:
  3571. begin
  3572. sym:=tenumdef(typekindtype).int2enumsym(get_typekind(left.resultdef));
  3573. if not assigned(sym) then
  3574. internalerror(2017081101);
  3575. if sym.typ<>enumsym then
  3576. internalerror(2017081102);
  3577. result:=genenumnode(tenumsym(sym));
  3578. end;
  3579. in_ismanagedtype_x:
  3580. begin
  3581. if left.resultdef.needs_inittable then
  3582. result:=cordconstnode.create(1,resultdef,false)
  3583. else
  3584. result:=cordconstnode.create(0,resultdef,false);
  3585. end;
  3586. in_assigned_x:
  3587. begin
  3588. result:=first_assigned;
  3589. end;
  3590. in_pred_x,
  3591. in_succ_x:
  3592. begin
  3593. expectloc:=LOC_REGISTER;
  3594. { in case of range/overflow checking, use a regular addnode
  3595. because it's too complex to handle correctly otherwise }
  3596. {$ifndef jvm}
  3597. { enums are class instances in the JVM -> always need conversion }
  3598. if (([cs_check_overflow,cs_check_range]*current_settings.localswitches)<>[]) and not(nf_internal in flags) then
  3599. {$endif}
  3600. begin
  3601. { create constant 1 }
  3602. hp:=cordconstnode.create(1,left.resultdef,false);
  3603. typecheckpass(hp);
  3604. if not is_integer(hp.resultdef) then
  3605. inserttypeconv_internal(hp,sinttype);
  3606. { avoid type errors from the addn/subn }
  3607. if not is_integer(left.resultdef) then
  3608. inserttypeconv_internal(left,sinttype);
  3609. { addition/substraction depending on succ/pred }
  3610. if inlinenumber=in_succ_x then
  3611. hp:=caddnode.create(addn,left,hp)
  3612. else
  3613. hp:=caddnode.create(subn,left,hp);
  3614. { the condition above is not tested for jvm, so we need to avoid overflow checks here
  3615. by setting nf_internal for the add/sub node as well }
  3616. if nf_internal in flags then
  3617. include(hp.flags,nf_internal);
  3618. { assign result of addition }
  3619. if not(is_integer(resultdef)) then
  3620. inserttypeconv(hp,corddef.create(
  3621. {$ifdef cpu64bitaddr}
  3622. s64bit,
  3623. {$else cpu64bitaddr}
  3624. s32bit,
  3625. {$endif cpu64bitaddr}
  3626. get_min_value(resultdef),
  3627. get_max_value(resultdef),
  3628. true))
  3629. else
  3630. inserttypeconv(hp,resultdef);
  3631. if nf_internal in flags then
  3632. include(hp.flags,nf_internal);
  3633. { avoid any possible errors/warnings }
  3634. inserttypeconv_internal(hp,resultdef);
  3635. { firstpass it }
  3636. firstpass(hp);
  3637. { left is reused }
  3638. left:=nil;
  3639. { return new node }
  3640. result:=hp;
  3641. end;
  3642. end;
  3643. in_setlength_x:
  3644. result:=first_setlength;
  3645. in_copy_x:
  3646. result:=first_copy;
  3647. in_initialize_x,
  3648. in_finalize_x:
  3649. begin
  3650. expectloc:=LOC_VOID;
  3651. end;
  3652. in_inc_x,
  3653. in_dec_x:
  3654. begin
  3655. result:=first_IncDec;
  3656. end;
  3657. in_and_assign_x_y,
  3658. in_or_assign_x_y,
  3659. in_xor_assign_x_y,
  3660. in_sar_assign_x_y,
  3661. in_shl_assign_x_y,
  3662. in_shr_assign_x_y,
  3663. in_rol_assign_x_y,
  3664. in_ror_assign_x_y:
  3665. begin
  3666. result:=first_AndOrXorShiftRot_assign;
  3667. end;
  3668. in_neg_assign_x,
  3669. in_not_assign_x:
  3670. begin
  3671. result:=first_NegNot_assign;
  3672. end;
  3673. in_include_x_y,
  3674. in_exclude_x_y:
  3675. begin
  3676. result:=first_IncludeExclude;
  3677. end;
  3678. in_pack_x_y_z,
  3679. in_unpack_x_y_z:
  3680. begin
  3681. result:=first_pack_unpack;
  3682. end;
  3683. in_exp_real:
  3684. begin
  3685. result:= first_exp_real;
  3686. end;
  3687. in_round_real:
  3688. begin
  3689. result:= first_round_real;
  3690. end;
  3691. in_trunc_real:
  3692. begin
  3693. result:= first_trunc_real;
  3694. end;
  3695. in_int_real:
  3696. begin
  3697. result:= first_int_real;
  3698. end;
  3699. in_frac_real:
  3700. begin
  3701. result:= first_frac_real;
  3702. end;
  3703. in_cos_real:
  3704. begin
  3705. result:= first_cos_real;
  3706. end;
  3707. in_sin_real:
  3708. begin
  3709. result := first_sin_real;
  3710. end;
  3711. in_arctan_real:
  3712. begin
  3713. result := first_arctan_real;
  3714. end;
  3715. in_pi_real :
  3716. begin
  3717. result := first_pi;
  3718. end;
  3719. in_abs_real:
  3720. begin
  3721. result := first_abs_real;
  3722. end;
  3723. in_abs_long:
  3724. begin
  3725. result := first_abs_long;
  3726. end;
  3727. in_sqr_real:
  3728. begin
  3729. result := first_sqr_real;
  3730. end;
  3731. in_sqrt_real:
  3732. begin
  3733. result := first_sqrt_real;
  3734. end;
  3735. in_ln_real:
  3736. begin
  3737. result := first_ln_real;
  3738. end;
  3739. {$ifdef SUPPORT_MMX}
  3740. in_mmx_pcmpeqb..in_mmx_pcmpgtw:
  3741. begin
  3742. end;
  3743. {$endif SUPPORT_MMX}
  3744. in_assert_x_y :
  3745. begin
  3746. result:=first_assert;
  3747. end;
  3748. in_low_x:
  3749. internalerror(200104047);
  3750. in_high_x:
  3751. begin
  3752. result:=first_high;
  3753. end;
  3754. in_slice_x:
  3755. internalerror(2005101501);
  3756. in_ord_x,
  3757. in_chr_byte:
  3758. begin
  3759. { should not happend as it's converted to typeconv }
  3760. internalerror(200104045);
  3761. end;
  3762. in_ofs_x :
  3763. internalerror(2000101001);
  3764. in_seg_x :
  3765. begin
  3766. result:=first_seg;
  3767. end;
  3768. in_settextbuf_file_x,
  3769. in_reset_typedfile,
  3770. in_rewrite_typedfile,
  3771. in_reset_typedfile_name,
  3772. in_rewrite_typedfile_name,
  3773. in_str_x_string,
  3774. in_val_x,
  3775. in_read_x,
  3776. in_readln_x,
  3777. in_write_x,
  3778. in_writeln_x :
  3779. begin
  3780. { should be handled by pass_typecheck }
  3781. internalerror(200108234);
  3782. end;
  3783. in_get_frame:
  3784. begin
  3785. result:=first_get_frame;
  3786. end;
  3787. in_get_caller_frame:
  3788. begin
  3789. expectloc:=LOC_REGISTER;
  3790. end;
  3791. in_get_caller_addr:
  3792. begin
  3793. expectloc:=LOC_REGISTER;
  3794. end;
  3795. in_prefetch_var:
  3796. begin
  3797. expectloc:=LOC_VOID;
  3798. end;
  3799. in_aligned_x,
  3800. in_unaligned_x,
  3801. in_volatile_x:
  3802. begin
  3803. expectloc:=tcallparanode(left).left.expectloc;
  3804. end;
  3805. in_rol_x,
  3806. in_rol_x_y,
  3807. in_ror_x,
  3808. in_ror_x_y:
  3809. expectloc:=LOC_REGISTER;
  3810. in_bsf_x,
  3811. in_bsr_x:
  3812. result:=first_bitscan;
  3813. in_sar_x,
  3814. in_sar_x_y:
  3815. result:=first_sar;
  3816. in_popcnt_x:
  3817. result:=first_popcnt;
  3818. in_new_x:
  3819. result:=first_new;
  3820. in_box_x:
  3821. result:=first_box;
  3822. in_unbox_x_y:
  3823. result:=first_unbox;
  3824. in_fma_single,
  3825. in_fma_double,
  3826. in_fma_extended,
  3827. in_fma_float128:
  3828. result:=first_fma;
  3829. else
  3830. result:=first_cpu;
  3831. end;
  3832. end;
  3833. {$maxfpuregisters default}
  3834. function tinlinenode.docompare(p: tnode): boolean;
  3835. begin
  3836. docompare :=
  3837. inherited docompare(p) and
  3838. (inlinenumber = tinlinenode(p).inlinenumber);
  3839. end;
  3840. procedure tinlinenode.mark_write;
  3841. begin
  3842. case inlinenumber of
  3843. in_aligned_x, in_unaligned_x:
  3844. tcallparanode(left).left.mark_write;
  3845. else
  3846. inherited mark_write;
  3847. end;
  3848. end;
  3849. function tinlinenode.first_pi : tnode;
  3850. begin
  3851. result:=crealconstnode.create(getpi,pbestrealtype^);
  3852. end;
  3853. function tinlinenode.first_arctan_real : tnode;
  3854. begin
  3855. { create the call to the helper }
  3856. { on entry left node contains the parameter }
  3857. result := ccallnode.createintern('fpc_arctan_real',
  3858. ccallparanode.create(left,nil));
  3859. left := nil;
  3860. end;
  3861. function tinlinenode.first_abs_real : tnode;
  3862. var
  3863. callnode : tcallnode;
  3864. begin
  3865. { create the call to the helper }
  3866. { on entry left node contains the parameter }
  3867. callnode:=ccallnode.createintern('fpc_abs_real',
  3868. ccallparanode.create(left,nil));
  3869. result := ctypeconvnode.create(callnode,resultdef);
  3870. include(callnode.callnodeflags,cnf_check_fpu_exceptions);
  3871. left := nil;
  3872. end;
  3873. function tinlinenode.first_sqr_real : tnode;
  3874. var
  3875. callnode : tcallnode;
  3876. begin
  3877. {$ifndef cpufpemu}
  3878. { this procedure might be only used for cpus definining cpufpemu else
  3879. the optimizer might go into an endless loop when doing x*x -> changes }
  3880. internalerror(2011092401);
  3881. {$endif cpufpemu}
  3882. { create the call to the helper }
  3883. { on entry left node contains the parameter }
  3884. callnode:=ccallnode.createintern('fpc_sqr_real',
  3885. ccallparanode.create(left,nil));
  3886. result := ctypeconvnode.create(callnode,resultdef);
  3887. include(callnode.callnodeflags,cnf_check_fpu_exceptions);
  3888. left := nil;
  3889. end;
  3890. function tinlinenode.first_sqrt_real : tnode;
  3891. var
  3892. fdef: tdef;
  3893. procname: string[31];
  3894. callnode: tcallnode;
  3895. begin
  3896. if ((cs_fp_emulation in current_settings.moduleswitches)
  3897. {$ifdef cpufpemu}
  3898. or (current_settings.fputype=fpu_soft)
  3899. {$endif cpufpemu}
  3900. ) and not (target_info.system in systems_wince) then
  3901. begin
  3902. case tfloatdef(left.resultdef).floattype of
  3903. s32real:
  3904. begin
  3905. fdef:=search_system_type('FLOAT32REC').typedef;
  3906. procname:='float32_sqrt';
  3907. end;
  3908. s64real:
  3909. begin
  3910. fdef:=search_system_type('FLOAT64').typedef;
  3911. procname:='float64_sqrt';
  3912. end;
  3913. {!!! not yet implemented
  3914. s128real:
  3915. }
  3916. else
  3917. internalerror(2014052101);
  3918. end;
  3919. result:=ctypeconvnode.create_internal(ccallnode.createintern(procname,ccallparanode.create(
  3920. ctypeconvnode.create_internal(left,fdef),nil)),resultdef);
  3921. end
  3922. else
  3923. begin
  3924. { create the call to the helper }
  3925. { on entry left node contains the parameter }
  3926. callnode := ccallnode.createintern('fpc_sqrt_real',
  3927. ccallparanode.create(left,nil));
  3928. result := ctypeconvnode.create(callnode,resultdef);
  3929. include(callnode.callnodeflags,cnf_check_fpu_exceptions);
  3930. end;
  3931. left := nil;
  3932. end;
  3933. function tinlinenode.first_ln_real : tnode;
  3934. begin
  3935. { create the call to the helper }
  3936. { on entry left node contains the parameter }
  3937. result := ccallnode.createintern('fpc_ln_real',
  3938. ccallparanode.create(left,nil));
  3939. include(tcallnode(result).callnodeflags,cnf_check_fpu_exceptions);
  3940. left := nil;
  3941. end;
  3942. function tinlinenode.first_cos_real : tnode;
  3943. begin
  3944. { create the call to the helper }
  3945. { on entry left node contains the parameter }
  3946. result := ccallnode.createintern('fpc_cos_real',
  3947. ccallparanode.create(left,nil));
  3948. include(tcallnode(result).callnodeflags,cnf_check_fpu_exceptions);
  3949. left := nil;
  3950. end;
  3951. function tinlinenode.first_sin_real : tnode;
  3952. begin
  3953. { create the call to the helper }
  3954. { on entry left node contains the parameter }
  3955. result := ccallnode.createintern('fpc_sin_real',
  3956. ccallparanode.create(left,nil));
  3957. include(tcallnode(result).callnodeflags,cnf_check_fpu_exceptions);
  3958. left := nil;
  3959. end;
  3960. function tinlinenode.first_exp_real : tnode;
  3961. begin
  3962. { create the call to the helper }
  3963. { on entry left node contains the parameter }
  3964. result := ccallnode.createintern('fpc_exp_real',ccallparanode.create(left,nil));
  3965. include(tcallnode(result).callnodeflags,cnf_check_fpu_exceptions);
  3966. left := nil;
  3967. end;
  3968. function tinlinenode.first_int_real : tnode;
  3969. begin
  3970. { create the call to the helper }
  3971. { on entry left node contains the parameter }
  3972. result := ccallnode.createintern('fpc_int_real',ccallparanode.create(left,nil));
  3973. include(tcallnode(result).callnodeflags,cnf_check_fpu_exceptions);
  3974. left := nil;
  3975. end;
  3976. function tinlinenode.first_frac_real : tnode;
  3977. begin
  3978. { create the call to the helper }
  3979. { on entry left node contains the parameter }
  3980. result := ccallnode.createintern('fpc_frac_real',ccallparanode.create(left,nil));
  3981. include(tcallnode(result).callnodeflags,cnf_check_fpu_exceptions);
  3982. left := nil;
  3983. end;
  3984. function tinlinenode.first_round_real : tnode;
  3985. begin
  3986. { create the call to the helper }
  3987. { on entry left node contains the parameter }
  3988. result := ccallnode.createintern('fpc_round_real',ccallparanode.create(left,nil));
  3989. include(tcallnode(result).callnodeflags,cnf_check_fpu_exceptions);
  3990. left := nil;
  3991. end;
  3992. function tinlinenode.first_trunc_real : tnode;
  3993. begin
  3994. { create the call to the helper }
  3995. { on entry left node contains the parameter }
  3996. result := ccallnode.createintern('fpc_trunc_real',ccallparanode.create(left,nil));
  3997. include(tcallnode(result).callnodeflags,cnf_check_fpu_exceptions);
  3998. left := nil;
  3999. end;
  4000. function tinlinenode.first_abs_long : tnode;
  4001. begin
  4002. expectloc:=LOC_REGISTER;
  4003. result:=nil;
  4004. end;
  4005. function tinlinenode.getaddsub_for_incdec : tnode;
  4006. var
  4007. hp,hpp,resultnode : tnode;
  4008. tempnode: ttempcreatenode;
  4009. newstatement: tstatementnode;
  4010. newblock: tblocknode;
  4011. begin
  4012. newblock := internalstatements(newstatement);
  4013. { extra parameter? }
  4014. if assigned(tcallparanode(left).right) then
  4015. begin
  4016. { Yes, use for add node }
  4017. hpp := tcallparanode(tcallparanode(left).right).left;
  4018. tcallparanode(tcallparanode(left).right).left := nil;
  4019. if assigned(tcallparanode(tcallparanode(left).right).right) then
  4020. CGMessage(parser_e_illegal_expression);
  4021. end
  4022. else
  4023. begin
  4024. { no, create constant 1 }
  4025. hpp := cordconstnode.create(1,tcallparanode(left).left.resultdef,false);
  4026. end;
  4027. typecheckpass(hpp);
  4028. { make sure we don't call functions part of the left node twice (and generally }
  4029. { optimize the code generation) }
  4030. { Storing address is not always an optimization: alignment of left is not known
  4031. at this point, so we must assume the worst and use an unaligned pointer.
  4032. This results in larger and slower code on alignment-sensitive targets.
  4033. Therefore the complexity condition below is questionable, maybe just filtering
  4034. out calls with "= NODE_COMPLEXITY_INF" is sufficient.
  4035. Value of 3 corresponds to subscript nodes, i.e. record field. }
  4036. if node_complexity(tcallparanode(left).left) > 3 then
  4037. begin
  4038. tempnode := ctempcreatenode.create(voidpointertype,voidpointertype.size,tt_persistent,true);
  4039. addstatement(newstatement,tempnode);
  4040. addstatement(newstatement,cassignmentnode.create(ctemprefnode.create(tempnode),
  4041. caddrnode.create_internal(tcallparanode(left).left.getcopy)));
  4042. hp := cderefnode.create(ctemprefnode.create(tempnode));
  4043. inserttypeconv_internal(hp,tcallparanode(left).left.resultdef);
  4044. end
  4045. else
  4046. begin
  4047. hp := tcallparanode(left).left.getcopy;
  4048. tempnode := nil;
  4049. end;
  4050. resultnode := hp.getcopy;
  4051. { avoid type errors from the addn/subn }
  4052. if not is_integer(resultnode.resultdef) then
  4053. begin
  4054. inserttypeconv_internal(hp,sinttype);
  4055. inserttypeconv_internal(hpp,sinttype);
  4056. end;
  4057. { addition/substraction depending on inc/dec }
  4058. if inlinenumber = in_inc_x then
  4059. hpp := caddnode.create_internal(addn,hp,hpp)
  4060. else
  4061. hpp := caddnode.create_internal(subn,hp,hpp);
  4062. { assign result of addition }
  4063. { inherit internal flag }
  4064. if not(is_integer(resultnode.resultdef)) then
  4065. begin
  4066. if nf_internal in flags then
  4067. inserttypeconv_internal(hpp,corddef.create(
  4068. {$ifdef cpu64bitaddr}
  4069. s64bit,
  4070. {$else cpu64bitaddr}
  4071. s32bit,
  4072. {$endif cpu64bitaddr}
  4073. get_min_value(resultnode.resultdef),
  4074. get_max_value(resultnode.resultdef),
  4075. true))
  4076. else
  4077. inserttypeconv(hpp,corddef.create(
  4078. {$ifdef cpu64bitaddr}
  4079. s64bit,
  4080. {$else cpu64bitaddr}
  4081. s32bit,
  4082. {$endif cpu64bitaddr}
  4083. get_min_value(resultnode.resultdef),
  4084. get_max_value(resultnode.resultdef),
  4085. true))
  4086. end
  4087. else
  4088. begin
  4089. if nf_internal in flags then
  4090. inserttypeconv_internal(hpp,resultnode.resultdef)
  4091. else
  4092. inserttypeconv(hpp,resultnode.resultdef);
  4093. end;
  4094. { avoid any possible warnings }
  4095. inserttypeconv_internal(hpp,resultnode.resultdef);
  4096. { get varstates right }
  4097. node_reset_flags(hpp,[nf_pass1_done,nf_modify,nf_write]);
  4098. do_typecheckpass(hpp);
  4099. addstatement(newstatement,cassignmentnode.create(resultnode,hpp));
  4100. { force pass 1, so copied trees get first pass'ed as well and flags like nf_write, nf_call_unique
  4101. get set right }
  4102. node_reset_flags(newstatement.statement,[nf_pass1_done]);
  4103. { firstpass it }
  4104. firstpass(tnode(newstatement.left));
  4105. { deallocate the temp }
  4106. if assigned(tempnode) then
  4107. addstatement(newstatement,ctempdeletenode.create(tempnode));
  4108. { firstpass it }
  4109. firstpass(tnode(newblock));
  4110. { return new node }
  4111. result := newblock;
  4112. end;
  4113. function tinlinenode.first_IncDec: tnode;
  4114. begin
  4115. expectloc:=LOC_VOID;
  4116. result:=nil;
  4117. { range/overflow checking doesn't work properly }
  4118. { with the inc/dec code that's generated (JM) }
  4119. if ((localswitches * [cs_check_overflow,cs_check_range] <> []) and
  4120. { No overflow check for pointer operations, because inc(pointer,-1) will always
  4121. trigger an overflow. For uint32 it works because then the operation is done
  4122. in 64bit. Range checking is not applicable to pointers either }
  4123. (tcallparanode(left).left.resultdef.typ<>pointerdef))
  4124. {$ifdef jvm}
  4125. { enums are class instances on the JVM -> special treatment }
  4126. or (tcallparanode(left).left.resultdef.typ=enumdef)
  4127. {$endif}
  4128. then
  4129. { convert to simple add (JM) }
  4130. result:=getaddsub_for_incdec
  4131. end;
  4132. function tinlinenode.first_IncludeExclude: tnode;
  4133. begin
  4134. result:=nil;
  4135. expectloc:=LOC_VOID;
  4136. end;
  4137. function tinlinenode.first_get_frame: tnode;
  4138. begin
  4139. include(current_procinfo.flags,pi_needs_stackframe);
  4140. include(current_procinfo.flags,pi_uses_get_frame);
  4141. expectloc:=LOC_CREGISTER;
  4142. result:=nil;
  4143. end;
  4144. function tinlinenode.first_setlength: tnode;
  4145. var
  4146. paras : tnode;
  4147. npara,
  4148. ppn : tcallparanode;
  4149. dims,
  4150. counter : integer;
  4151. isarray : boolean;
  4152. destppn : tnode;
  4153. newstatement : tstatementnode;
  4154. temp : ttempcreatenode;
  4155. newblock : tnode;
  4156. begin
  4157. paras:=left;
  4158. ppn:=tcallparanode(paras);
  4159. dims:=0;
  4160. while assigned(ppn.right) do
  4161. begin
  4162. inc(dims);
  4163. ppn:=tcallparanode(ppn.right);
  4164. end;
  4165. destppn:=ppn.left;
  4166. isarray:=is_dynamic_array(destppn.resultdef);
  4167. { first param must be a string or dynamic array ...}
  4168. if isarray then
  4169. begin
  4170. { create statements with call initialize the arguments and
  4171. call fpc_dynarr_setlength }
  4172. newblock:=internalstatements(newstatement);
  4173. { get temp for array of lengths }
  4174. temp:=ctempcreatenode.create(carraydef.getreusable(sinttype,dims),dims*sinttype.size,tt_persistent,false);
  4175. addstatement(newstatement,temp);
  4176. { load array of lengths }
  4177. ppn:=tcallparanode(paras);
  4178. counter:=dims-1;
  4179. while assigned(ppn.right) do
  4180. begin
  4181. addstatement(newstatement,cassignmentnode.create(
  4182. cvecnode.create(
  4183. ctemprefnode.create(temp),
  4184. genintconstnode(counter)
  4185. ),
  4186. ppn.left));
  4187. ppn.left:=nil;
  4188. dec(counter);
  4189. ppn:=tcallparanode(ppn.right);
  4190. end;
  4191. { destppn is also reused }
  4192. ppn.left:=nil;
  4193. { create call to fpc_dynarr_setlength }
  4194. npara:=ccallparanode.create(caddrnode.create_internal(
  4195. cvecnode.create(
  4196. ctemprefnode.create(temp),
  4197. genintconstnode(0)
  4198. )),
  4199. ccallparanode.create(cordconstnode.create
  4200. (dims,sinttype,true),
  4201. ccallparanode.create(caddrnode.create_internal
  4202. (crttinode.create(tstoreddef(destppn.resultdef),initrtti,rdt_normal)),
  4203. ccallparanode.create(ctypeconvnode.create_internal(destppn,voidpointertype),nil))));
  4204. addstatement(newstatement,ccallnode.createintern('fpc_dynarray_setlength',npara));
  4205. addstatement(newstatement,ctempdeletenode.create(temp));
  4206. end
  4207. else if is_ansistring(destppn.resultdef) then
  4208. begin
  4209. newblock:=ccallnode.createintern(
  4210. 'fpc_'+tstringdef(destppn.resultdef).stringtypname+'_setlength',
  4211. ccallparanode.create(
  4212. cordconstnode.create(getparaencoding(destppn.resultdef),u16inttype,true),
  4213. paras
  4214. )
  4215. );
  4216. { we reused the parameters, make sure we don't release them }
  4217. left:=nil;
  4218. end
  4219. else
  4220. begin
  4221. { we can reuse the supplied parameters }
  4222. newblock:=ccallnode.createintern(
  4223. 'fpc_'+tstringdef(destppn.resultdef).stringtypname+'_setlength',paras);
  4224. { we reused the parameters, make sure we don't release them }
  4225. left:=nil;
  4226. end;
  4227. result:=newblock;
  4228. end;
  4229. function tinlinenode.first_copy: tnode;
  4230. var
  4231. lowppn,
  4232. highppn,
  4233. npara,
  4234. paras : tnode;
  4235. ppn : tcallparanode;
  4236. paradef : tdef;
  4237. counter : integer;
  4238. begin
  4239. { determine copy function to use based on the first argument,
  4240. also count the number of arguments in this loop }
  4241. counter:=1;
  4242. paras:=left;
  4243. ppn:=tcallparanode(paras);
  4244. while assigned(ppn.right) do
  4245. begin
  4246. inc(counter);
  4247. ppn:=tcallparanode(ppn.right);
  4248. end;
  4249. paradef:=ppn.left.resultdef;
  4250. { fill up third parameter }
  4251. if counter=2 then
  4252. begin
  4253. paras:=ccallparanode.create(cordconstnode.create(torddef(sinttype).high,sinttype,false),paras);
  4254. counter:=3;
  4255. end;
  4256. if is_ansistring(resultdef) then
  4257. { keep the specific kind of ansistringdef as result }
  4258. result:=ccallnode.createinternres('fpc_ansistr_copy',paras,resultdef)
  4259. else if is_widestring(resultdef) then
  4260. result:=ccallnode.createintern('fpc_widestr_copy',paras)
  4261. else if is_unicodestring(resultdef) then
  4262. result:=ccallnode.createintern('fpc_unicodestr_copy',paras)
  4263. { can't check for resultdef = cansichartype, because resultdef=
  4264. cshortstringtype here }
  4265. else if is_char(paradef) then
  4266. result:=ccallnode.createintern('fpc_char_copy',paras)
  4267. else if is_dynamic_array(resultdef) then
  4268. begin
  4269. { create statements with call }
  4270. case counter of
  4271. 1:
  4272. begin
  4273. { copy the whole array using [0..high(sizeint)] range }
  4274. highppn:=cordconstnode.create(torddef(sinttype).high,sinttype,false);
  4275. lowppn:=cordconstnode.create(0,sinttype,false);
  4276. end;
  4277. 3:
  4278. begin
  4279. highppn:=tcallparanode(paras).left.getcopy;
  4280. lowppn:=tcallparanode(tcallparanode(paras).right).left.getcopy;
  4281. end;
  4282. else
  4283. internalerror(2012100701);
  4284. end;
  4285. { create call to fpc_dynarray_copy }
  4286. npara:=ccallparanode.create(highppn,
  4287. ccallparanode.create(lowppn,
  4288. ccallparanode.create(caddrnode.create_internal
  4289. (crttinode.create(tstoreddef(paradef),initrtti,rdt_normal)),
  4290. ccallparanode.create
  4291. (ctypeconvnode.create_internal(ppn.left,voidpointertype),nil))));
  4292. result:=ccallnode.createinternres('fpc_dynarray_copy',npara,paradef);
  4293. ppn.left:=nil;
  4294. paras.free;
  4295. end
  4296. else
  4297. result:=ccallnode.createintern('fpc_shortstr_copy',paras);
  4298. { parameters are reused }
  4299. left:=nil;
  4300. end;
  4301. function tinlinenode.first_new: tnode;
  4302. var
  4303. newstatement : tstatementnode;
  4304. newblock : tblocknode;
  4305. temp : ttempcreatenode;
  4306. para : tcallparanode;
  4307. begin
  4308. { create statements with call to getmem+initialize }
  4309. newblock:=internalstatements(newstatement);
  4310. { create temp for result }
  4311. temp := ctempcreatenode.create(left.resultdef,left.resultdef.size,tt_persistent,true);
  4312. addstatement(newstatement,temp);
  4313. { create call to fpc_getmem }
  4314. para := ccallparanode.create(cordconstnode.create
  4315. (tpointerdef(left.resultdef).pointeddef.size,s32inttype,true),nil);
  4316. addstatement(newstatement,cassignmentnode.create(
  4317. ctemprefnode.create(temp),
  4318. ccallnode.createintern('fpc_getmem',para)));
  4319. { create call to fpc_initialize }
  4320. if is_managed_type(tpointerdef(left.resultdef).pointeddef) then
  4321. begin
  4322. para := ccallparanode.create(caddrnode.create_internal(crttinode.create
  4323. (tstoreddef(tpointerdef(left.resultdef).pointeddef),initrtti,rdt_normal)),
  4324. ccallparanode.create(ctemprefnode.create
  4325. (temp),nil));
  4326. addstatement(newstatement,ccallnode.createintern('fpc_initialize',para));
  4327. end;
  4328. { the last statement should return the value as
  4329. location and type, this is done be referencing the
  4330. temp and converting it first from a persistent temp to
  4331. normal temp }
  4332. addstatement(newstatement,ctempdeletenode.create_normal_temp(temp));
  4333. addstatement(newstatement,ctemprefnode.create(temp));
  4334. result:=newblock;
  4335. end;
  4336. function tinlinenode.first_length: tnode;
  4337. begin
  4338. result:=nil;
  4339. if is_shortstring(left.resultdef) then
  4340. expectloc:=left.expectloc
  4341. else
  4342. begin
  4343. { ansi/wide string }
  4344. expectloc:=LOC_REGISTER;
  4345. end;
  4346. end;
  4347. function tinlinenode.first_high: tnode;
  4348. begin
  4349. result:=nil;
  4350. if not(is_dynamic_array(left.resultdef)) then
  4351. Internalerror(2019122802);
  4352. expectloc:=LOC_REGISTER;
  4353. end;
  4354. function tinlinenode.first_assigned: tnode;
  4355. begin
  4356. { Comparison must not call procvars, indicate that with nf_load_procvar flag }
  4357. result:=caddnode.create(unequaln,tcallparanode(left).left,cnilnode.create);
  4358. include(result.flags,nf_load_procvar);
  4359. tcallparanode(left).left:=nil;
  4360. end;
  4361. function tinlinenode.first_assert: tnode;
  4362. var
  4363. paras: tcallparanode;
  4364. begin
  4365. paras:=tcallparanode(tcallparanode(left).right);
  4366. paras:=ccallparanode.create(cstringconstnode.createstr(current_module.sourcefiles.get_file_name(current_filepos.fileindex)),paras);
  4367. paras:=ccallparanode.create(genintconstnode(fileinfo.line),paras);
  4368. {$ifdef SUPPORT_GET_FRAME}
  4369. paras:=ccallparanode.create(geninlinenode(in_get_frame,false,nil),paras);
  4370. {$else}
  4371. paras:=ccallparanode.create(ccallnode.createinternfromunit('SYSTEM','GET_FRAME',nil),paras);
  4372. {$endif}
  4373. result:=cifnode.create(cnotnode.create(tcallparanode(left).left),
  4374. ccallnode.createintern('fpc_assert',paras),nil);
  4375. include(result.flags,nf_internal);
  4376. tcallparanode(left).left:=nil;
  4377. tcallparanode(left).right:=nil;
  4378. end;
  4379. function tinlinenode.first_popcnt: tnode;
  4380. var
  4381. suffix : string;
  4382. begin
  4383. case torddef(left.resultdef).ordtype of
  4384. u8bit: suffix:='byte';
  4385. u16bit: suffix:='word';
  4386. u32bit: suffix:='dword';
  4387. u64bit: suffix:='qword';
  4388. else
  4389. internalerror(2012082601);
  4390. end;
  4391. result:=ccallnode.createintern('fpc_popcnt_'+suffix,ccallparanode.create(left,nil));
  4392. left:=nil;
  4393. end;
  4394. function tinlinenode.first_bitscan: tnode;
  4395. begin
  4396. result:=nil;
  4397. expectloc:=LOC_REGISTER;
  4398. end;
  4399. function tinlinenode.typecheck_seg: tnode;
  4400. begin
  4401. if target_info.system in systems_managed_vm then
  4402. message(parser_e_feature_unsupported_for_vm);
  4403. set_varstate(left,vs_read,[]);
  4404. result:=cordconstnode.create(0,s32inttype,false);
  4405. end;
  4406. function tinlinenode.first_seg: tnode;
  4407. begin
  4408. internalerror(200104046);
  4409. result:=nil;
  4410. end;
  4411. function tinlinenode.first_sar: tnode;
  4412. begin
  4413. result:=nil;
  4414. expectloc:=LOC_REGISTER;
  4415. {$if not defined(cpu64bitalu) and not defined(cpucg64shiftsupport)}
  4416. if is_64bitint(resultdef) then
  4417. begin
  4418. if (inlinenumber=in_sar_x) then
  4419. left:=ccallparanode.create(cordconstnode.create(1,u8inttype,false),
  4420. ccallparanode.create(left,nil));
  4421. result:=ccallnode.createintern('fpc_sarint64',left);
  4422. left:=nil;
  4423. end;
  4424. {$endif not defined(cpu64bitalu) and not defined(cpucg64shiftsupport)}
  4425. end;
  4426. function tinlinenode.handle_box: tnode;
  4427. begin
  4428. result:=nil;
  4429. if not assigned(left) or
  4430. assigned(tcallparanode(left).right) then
  4431. CGMessage1(parser_e_wrong_parameter_size,'FpcInternalBox');
  4432. resultdef:=class_tobject;
  4433. end;
  4434. function tinlinenode.handle_unbox: tnode;
  4435. begin
  4436. result:=nil;
  4437. if not assigned(left) or
  4438. not assigned(tcallparanode(left).right) or
  4439. assigned(tcallparanode(tcallparanode(left).right).right) then
  4440. CGMessage1(parser_e_wrong_parameter_size,'FpcInternalUnBox');
  4441. if tcallparanode(left).left.nodetype<>typen then
  4442. internalerror(2011071701);
  4443. ttypenode(tcallparanode(left).left).allowed:=true;
  4444. resultdef:=tcallparanode(left).left.resultdef;
  4445. end;
  4446. function tinlinenode.handle_insert: tnode;
  4447. procedure do_error;
  4448. begin
  4449. CGMessagePos1(fileinfo,parser_e_wrong_parameter_size,'Insert');
  4450. write_system_parameter_lists('fpc_shortstr_insert');
  4451. write_system_parameter_lists('fpc_shortstr_insert_char');
  4452. write_system_parameter_lists('fpc_unicodestr_insert');
  4453. if tf_winlikewidestring in target_info.flags then
  4454. write_system_parameter_lists('fpc_widestr_insert');
  4455. write_system_parameter_lists('fpc_ansistr_insert');
  4456. MessagePos1(fileinfo,sym_e_param_list,'Insert(Dynamic Array;var Dynamic Array;'+sinttype.typename+');');
  4457. MessagePos1(fileinfo,sym_e_param_list,'Insert(Element;var Dynamic Array;'+sinttype.typename+');');
  4458. end;
  4459. var
  4460. procname : String;
  4461. newn,
  4462. datan,
  4463. datacountn,
  4464. firstn,
  4465. secondn : tnode;
  4466. first,
  4467. second : tdef;
  4468. isconstr,
  4469. iscomparray,
  4470. iscompelem : boolean;
  4471. datatemp : ttempcreatenode;
  4472. insertblock : tblocknode;
  4473. insertstatement : tstatementnode;
  4474. begin
  4475. if not assigned(left) or
  4476. not assigned(tcallparanode(left).right) or
  4477. not assigned(tcallparanode(tcallparanode(left).right).right) or
  4478. assigned(tcallparanode(tcallparanode(tcallparanode(left).right).right).right) then
  4479. begin
  4480. do_error;
  4481. exit(cerrornode.create);
  4482. end;
  4483. { determine the correct function based on the second parameter }
  4484. firstn:=tcallparanode(tcallparanode(tcallparanode(left).right).right).left;
  4485. first:=firstn.resultdef;
  4486. secondn:=tcallparanode(tcallparanode(left).right).left;
  4487. second:=secondn.resultdef;
  4488. if is_shortstring(second) then
  4489. begin
  4490. if is_char(first) then
  4491. procname:='fpc_shortstr_insert_char'
  4492. else
  4493. procname:='fpc_shortstr_insert';
  4494. end
  4495. else if is_unicodestring(second) then
  4496. procname:='fpc_unicodestr_insert'
  4497. else if is_widestring(second) then
  4498. procname:='fpc_widestr_insert'
  4499. else if is_ansistring(second) then
  4500. procname:='fpc_ansistr_insert'
  4501. else if is_dynamic_array(second) then
  4502. begin
  4503. { The first parameter needs to be
  4504. a) a dynamic array of the same type
  4505. b) a single element of the same type
  4506. c) a static array of the same type (not Delphi compatible)
  4507. }
  4508. isconstr:=is_array_constructor(first);
  4509. iscomparray:=(first.typ=arraydef) and equal_defs(tarraydef(first).elementdef,tarraydef(second).elementdef);
  4510. iscompelem:=compare_defs(first,tarraydef(second).elementdef,niln)<>te_incompatible;
  4511. if not iscomparray
  4512. and not iscompelem
  4513. and not isconstr then
  4514. begin
  4515. CGMessagePos(fileinfo,type_e_array_required);
  4516. exit(cerrornode.create);
  4517. end;
  4518. insertblock:=internalstatements(insertstatement);
  4519. datatemp:=nil;
  4520. if iscomparray then
  4521. begin
  4522. datatemp:=ctempcreatenode.create_value(first,first.size,tt_normal,false,firstn);
  4523. addstatement(insertstatement,datatemp);
  4524. if is_dynamic_array(first) then
  4525. datan:=ctypeconvnode.create_internal(ctemprefnode.create(datatemp),voidpointertype)
  4526. else
  4527. datan:=caddrnode.create_internal(cvecnode.create(ctemprefnode.create(datatemp),cordconstnode.create(0,sizesinttype,false)));
  4528. datacountn:=cinlinenode.create(in_length_x,false,ctemprefnode.create(datatemp));
  4529. end
  4530. else if isconstr then
  4531. begin
  4532. inserttypeconv(firstn,second);
  4533. datatemp:=ctempcreatenode.create_value(second,second.size,tt_normal,false,firstn);
  4534. addstatement(insertstatement,datatemp);
  4535. datan:=ctypeconvnode.create_internal(ctemprefnode.create(datatemp),voidpointertype);
  4536. datacountn:=cinlinenode.create(in_length_x,false,ctemprefnode.create(datatemp));
  4537. end
  4538. else
  4539. begin
  4540. if is_const(firstn) then
  4541. begin
  4542. datatemp:=ctempcreatenode.create_value(tarraydef(second).elementdef,tarraydef(second).elementdef.size,tt_normal,false,firstn);
  4543. addstatement(insertstatement,datatemp);
  4544. datan:=caddrnode.create_internal(ctemprefnode.create(datatemp));
  4545. end
  4546. else
  4547. datan:=caddrnode.create_internal(ctypeconvnode.create_internal(firstn,tarraydef(second).elementdef));
  4548. datacountn:=cordconstnode.create(1,sizesinttype,false);
  4549. end;
  4550. procname:='fpc_dynarray_insert';
  4551. { recreate the parameters as array pointer, source, data, count, typeinfo }
  4552. newn:=ccallparanode.create(caddrnode.create_internal(crttinode.create(tstoreddef(second),initrtti,rdt_normal)),
  4553. ccallparanode.create(datacountn,
  4554. ccallparanode.create(datan,
  4555. ccallparanode.create(tcallparanode(left).left,
  4556. ccallparanode.create(ctypeconvnode.create_internal(secondn,voidpointertype),nil)))));
  4557. addstatement(insertstatement,ccallnode.createintern(procname,newn));
  4558. if assigned(datatemp) then
  4559. addstatement(insertstatement,ctempdeletenode.create(datatemp));
  4560. tcallparanode(tcallparanode(tcallparanode(left).right).right).left:=nil; // insert idx
  4561. tcallparanode(tcallparanode(left).right).left:=nil; // dyn array
  4562. tcallparanode(left).left:=nil; // insert element/array
  4563. left.free;
  4564. left:=nil;
  4565. result:=insertblock;
  4566. exit; { ! }
  4567. end
  4568. else if second.typ=undefineddef then
  4569. { just pick one }
  4570. procname:='fpc_ansistr_insert'
  4571. else
  4572. begin
  4573. do_error;
  4574. exit(cerrornode.create);
  4575. end;
  4576. result:=ccallnode.createintern(procname,left);
  4577. left:=nil;
  4578. end;
  4579. function tinlinenode.handle_delete: tnode;
  4580. procedure do_error;
  4581. begin
  4582. CGMessagePos1(fileinfo,parser_e_wrong_parameter_size,'Delete');
  4583. write_system_parameter_lists('fpc_shortstr_delete');
  4584. write_system_parameter_lists('fpc_unicodestr_delete');
  4585. if tf_winlikewidestring in target_info.flags then
  4586. write_system_parameter_lists('fpc_widestr_delete');
  4587. write_system_parameter_lists('fpc_ansistr_delete');
  4588. MessagePos1(fileinfo,sym_e_param_list,'Delete(var Dynamic Array;'+sinttype.typename+';'+sinttype.typename+');');
  4589. end;
  4590. var
  4591. procname : String;
  4592. first : tdef;
  4593. firstn,
  4594. newn : tnode;
  4595. begin
  4596. if not assigned(left) or
  4597. not assigned(tcallparanode(left).right) or
  4598. not assigned(tcallparanode(tcallparanode(left).right).right) or
  4599. assigned(tcallparanode(tcallparanode(tcallparanode(left).right).right).right) then
  4600. begin
  4601. do_error;
  4602. exit(cerrornode.create);
  4603. end;
  4604. { determine the correct function based on the first parameter }
  4605. firstn:=tcallparanode(tcallparanode(tcallparanode(left).right).right).left;
  4606. first:=firstn.resultdef;
  4607. if is_shortstring(first) then
  4608. procname:='fpc_shortstr_delete'
  4609. else if is_unicodestring(first) then
  4610. procname:='fpc_unicodestr_delete'
  4611. else if is_widestring(first) then
  4612. procname:='fpc_widestr_delete'
  4613. else if is_ansistring(first) then
  4614. procname:='fpc_ansistr_delete'
  4615. else if is_dynamic_array(first) then
  4616. begin
  4617. procname:='fpc_dynarray_delete';
  4618. { recreate the parameters as array pointer, src, count, typeinfo }
  4619. newn:=ccallparanode.create(caddrnode.create_internal
  4620. (crttinode.create(tstoreddef(first),initrtti,rdt_normal)),
  4621. ccallparanode.create(tcallparanode(left).left,
  4622. ccallparanode.create(tcallparanode(tcallparanode(left).right).left,
  4623. ccallparanode.create(ctypeconvnode.create_internal(firstn,voidpointertype),nil))));
  4624. tcallparanode(tcallparanode(tcallparanode(left).right).right).left:=nil;
  4625. tcallparanode(tcallparanode(left).right).left:=nil;
  4626. tcallparanode(left).left:=nil;
  4627. left.free;
  4628. left:=newn;
  4629. end
  4630. else if first.typ=undefineddef then
  4631. { just pick one }
  4632. procname:='fpc_ansistr_delete'
  4633. else
  4634. begin
  4635. do_error;
  4636. exit(cerrornode.create);
  4637. end;
  4638. result:=ccallnode.createintern(procname,left);
  4639. left:=nil;
  4640. end;
  4641. function tinlinenode.handle_concat:tnode;
  4642. procedure do_error;
  4643. begin
  4644. CGMessagePos1(fileinfo,parser_e_wrong_parameter_size,'Concat');
  4645. MessagePos1(fileinfo,sym_e_param_list,'Concat(String[;String;...])');
  4646. MessagePos1(fileinfo,sym_e_param_list,'Concat(Dynamic Array[;Dynamic Array;...])');
  4647. end;
  4648. var
  4649. cpn : tcallparanode;
  4650. list : tfpobjectlist;
  4651. n,
  4652. arrn,
  4653. firstn : tnode;
  4654. i : longint;
  4655. arrconstr : tarrayconstructornode;
  4656. newstatement : tstatementnode;
  4657. tempnode : ttempcreatenode;
  4658. lastchanged : boolean;
  4659. begin
  4660. if not assigned(left) then
  4661. begin
  4662. do_error;
  4663. exit(cerrornode.create);
  4664. end;
  4665. result:=nil;
  4666. { the arguments are right to left, but we need to work on them from
  4667. left to right, so insert them in a list and process that from back
  4668. to front }
  4669. list:=tfpobjectlist.create(false);
  4670. { remember the last (aka first) dynamic array parameter (important
  4671. in case of array constructors) }
  4672. arrn:=nil;
  4673. cpn:=tcallparanode(left);
  4674. while assigned(cpn) do
  4675. begin
  4676. list.add(cpn.left);
  4677. if is_dynamic_array(cpn.left.resultdef) then
  4678. arrn:=cpn.left;
  4679. cpn.left:=nil;
  4680. cpn:=tcallparanode(cpn.right);
  4681. end;
  4682. if list.count=0 then
  4683. internalerror(2017100901);
  4684. firstn:=tnode(list.last);
  4685. if not assigned(firstn) then
  4686. internalerror(2017100902);
  4687. { are we dealing with strings or dynamic arrays? }
  4688. if is_dynamic_array(firstn.resultdef) or is_array_constructor(firstn.resultdef) then
  4689. begin
  4690. { try to combine all consecutive array constructors }
  4691. lastchanged:=false;
  4692. i:=0;
  4693. repeat
  4694. if lastchanged or is_array_constructor(tnode(list[i]).resultdef) then
  4695. begin
  4696. if (i<list.count-1) and is_array_constructor(tnode(list[i+1]).resultdef) then
  4697. begin
  4698. arrconstr:=tarrayconstructornode(list[i+1]);
  4699. while assigned(arrconstr.right) do
  4700. arrconstr:=tarrayconstructornode(arrconstr.right);
  4701. arrconstr.right:=tnode(list[i]);
  4702. list[i]:=list[i+1];
  4703. list.delete(i+1);
  4704. lastchanged:=true;
  4705. tnode(list[i]).resultdef:=nil;
  4706. { don't increase index! }
  4707. continue;
  4708. end;
  4709. if lastchanged then
  4710. begin
  4711. { we concatted all consecutive ones, so typecheck the new one again }
  4712. n:=tnode(list[i]);
  4713. typecheckpass(n);
  4714. list[i]:=n;
  4715. end;
  4716. lastchanged:=false;
  4717. end;
  4718. inc(i);
  4719. until i=list.count;
  4720. if list.count=1 then
  4721. begin
  4722. { no need to call the concat helper }
  4723. result:=firstn;
  4724. end
  4725. else
  4726. begin
  4727. { if we reach this point then the concat list didn't consist
  4728. solely of array constructors }
  4729. if not assigned(arrn) then
  4730. internalerror(2017101001);
  4731. result:=internalstatements(newstatement);
  4732. { generate the open array constructor for the source arrays
  4733. note: the order needs to be swapped again here! }
  4734. arrconstr:=nil;
  4735. for i:=0 to list.count-1 do
  4736. begin
  4737. n:=tnode(list[i]);
  4738. { first convert to the target type }
  4739. if not is_array_constructor(n.resultdef) then
  4740. inserttypeconv(n,arrn.resultdef);
  4741. { we need to ensure that we get a reference counted
  4742. assignement for the temp array }
  4743. tempnode:=ctempcreatenode.create(arrn.resultdef,arrn.resultdef.size,tt_persistent,true);
  4744. addstatement(newstatement,tempnode);
  4745. addstatement(newstatement,cassignmentnode.create(ctemprefnode.create(tempnode),n));
  4746. addstatement(newstatement,ctempdeletenode.create_normal_temp(tempnode));
  4747. n:=ctemprefnode.create(tempnode);
  4748. { then to a plain pointer for the helper }
  4749. inserttypeconv_internal(n,voidpointertype);
  4750. arrconstr:=carrayconstructornode.create(n,arrconstr);
  4751. end;
  4752. arrconstr.allow_array_constructor:=true;
  4753. { based on the code from nopt.genmultistringadd() }
  4754. tempnode:=ctempcreatenode.create(arrn.resultdef,arrn.resultdef.size,tt_persistent,true);
  4755. addstatement(newstatement,tempnode);
  4756. { initialize the temp, since it will be passed to a
  4757. var-parameter (and finalization, which is performed by the
  4758. ttempcreate node and which takes care of the initialization
  4759. on native targets, is a noop on managed VM targets) }
  4760. if (target_info.system in systems_managed_vm) and
  4761. is_managed_type(arrn.resultdef) then
  4762. addstatement(newstatement,cinlinenode.create(in_setlength_x,
  4763. false,
  4764. ccallparanode.create(genintconstnode(0),
  4765. ccallparanode.create(ctemprefnode.create(tempnode),nil))));
  4766. cpn:=ccallparanode.create(
  4767. arrconstr,
  4768. ccallparanode.create(
  4769. caddrnode.create_internal(crttinode.create(tstoreddef(arrn.resultdef),initrtti,rdt_normal)),
  4770. ccallparanode.create(ctypeconvnode.create_internal(ctemprefnode.create(tempnode),voidpointertype),nil))
  4771. );
  4772. addstatement(
  4773. newstatement,
  4774. ccallnode.createintern(
  4775. 'fpc_dynarray_concat_multi',
  4776. cpn
  4777. )
  4778. );
  4779. addstatement(newstatement,ctempdeletenode.create_normal_temp(tempnode));
  4780. addstatement(newstatement,ctemprefnode.create(tempnode));
  4781. end;
  4782. end
  4783. else
  4784. begin
  4785. { enforce strings }
  4786. for i:=list.count-1 downto 0 do
  4787. begin
  4788. if assigned(result) then
  4789. result:=caddnode.create(addn,result,tnode(list[i]))
  4790. else
  4791. begin
  4792. result:=tnode(list[i]);
  4793. { Force string type if it isn't yet }
  4794. if not(
  4795. (result.resultdef.typ=stringdef) or
  4796. is_chararray(result.resultdef) or
  4797. is_char(result.resultdef)
  4798. ) then
  4799. inserttypeconv(result,cshortstringtype);
  4800. end;
  4801. end;
  4802. end;
  4803. list.free;
  4804. end;
  4805. function tinlinenode.first_pack_unpack: tnode;
  4806. var
  4807. loopstatement : tstatementnode;
  4808. loop : tblocknode;
  4809. loopvar : ttempcreatenode;
  4810. tempnode,
  4811. source,
  4812. target,
  4813. index,
  4814. unpackednode,
  4815. packednode,
  4816. sourcevecindex,
  4817. targetvecindex,
  4818. loopbody : tnode;
  4819. temprangedef : tdef;
  4820. ulorange,
  4821. uhirange,
  4822. plorange,
  4823. phirange : TConstExprInt;
  4824. begin
  4825. { transform into a for loop which assigns the data of the (un)packed }
  4826. { array to the other one }
  4827. source := left;
  4828. if (inlinenumber = in_unpack_x_y_z) then
  4829. begin
  4830. target := tcallparanode(source).right;
  4831. index := tcallparanode(target).right;
  4832. packednode := tcallparanode(source).left;
  4833. unpackednode := tcallparanode(target).left;
  4834. end
  4835. else
  4836. begin
  4837. index := tcallparanode(source).right;
  4838. target := tcallparanode(index).right;
  4839. packednode := tcallparanode(target).left;
  4840. unpackednode := tcallparanode(source).left;
  4841. end;
  4842. source := tcallparanode(source).left;
  4843. target := tcallparanode(target).left;
  4844. index := tcallparanode(index).left;
  4845. loop := internalstatements(loopstatement);
  4846. loopvar := ctempcreatenode.create(
  4847. tarraydef(packednode.resultdef).rangedef,
  4848. tarraydef(packednode.resultdef).rangedef.size,
  4849. tt_persistent,true);
  4850. addstatement(loopstatement,loopvar);
  4851. { For range checking: we have to convert to an integer type (in case the index type }
  4852. { is an enum), add the index and loop variable together, convert the result }
  4853. { implicitly to an orddef with range equal to the rangedef to get range checking }
  4854. { and finally convert it explicitly back to the actual rangedef to avoid type }
  4855. { errors }
  4856. temprangedef:=nil;
  4857. getrange(unpackednode.resultdef,ulorange,uhirange);
  4858. getrange(packednode.resultdef,plorange,phirange);
  4859. { does not really need to be registered, but then we would have to
  4860. record it elsewhere so it still can be freed }
  4861. temprangedef:=corddef.create(torddef(sinttype).ordtype,ulorange,uhirange,true);
  4862. sourcevecindex := ctemprefnode.create(loopvar);
  4863. targetvecindex := ctypeconvnode.create_internal(index.getcopy,sinttype);
  4864. targetvecindex := caddnode.create(subn,targetvecindex,cordconstnode.create(plorange,sinttype,true));
  4865. targetvecindex := caddnode.create(addn,targetvecindex,ctemprefnode.create(loopvar));
  4866. targetvecindex := ctypeconvnode.create(targetvecindex,temprangedef);
  4867. targetvecindex := ctypeconvnode.create_explicit(targetvecindex,tarraydef(unpackednode.resultdef).rangedef);
  4868. if (inlinenumber = in_pack_x_y_z) then
  4869. begin
  4870. { swap source and target vec indices }
  4871. tempnode := sourcevecindex;
  4872. sourcevecindex := targetvecindex;
  4873. targetvecindex := tempnode;
  4874. end;
  4875. { create the assignment in the loop body }
  4876. loopbody :=
  4877. cassignmentnode.create(
  4878. cvecnode.create(target.getcopy,targetvecindex),
  4879. cvecnode.create(source.getcopy,sourcevecindex)
  4880. );
  4881. { create the actual for loop }
  4882. tempnode := cfornode.create(
  4883. ctemprefnode.create(loopvar),
  4884. cinlinenode.create(in_low_x,false,packednode.getcopy),
  4885. cinlinenode.create(in_high_x,false,packednode.getcopy),
  4886. loopbody,
  4887. false);
  4888. addstatement(loopstatement,tempnode);
  4889. { free the loop counter }
  4890. addstatement(loopstatement,ctempdeletenode.create(loopvar));
  4891. result := loop;
  4892. end;
  4893. function tinlinenode.may_have_sideeffect_norecurse: boolean;
  4894. begin
  4895. result:=
  4896. (inlinenumber in [in_write_x,in_writeln_x,in_read_x,in_readln_x,in_str_x_string,
  4897. in_val_x,in_reset_x,in_rewrite_x,in_reset_typedfile,in_rewrite_typedfile,
  4898. in_reset_typedfile_name,in_rewrite_typedfile_name,in_settextbuf_file_x,
  4899. in_inc_x,in_dec_x,in_include_x_y,in_exclude_x_y,in_break,in_continue,in_setlength_x,
  4900. in_finalize_x,in_new_x,in_dispose_x,in_exit,in_copy_x,in_initialize_x,in_leave,in_cycle,
  4901. in_and_assign_x_y,in_or_assign_x_y,in_xor_assign_x_y,in_sar_assign_x_y,in_shl_assign_x_y,
  4902. in_shr_assign_x_y,in_rol_assign_x_y,in_ror_assign_x_y,in_neg_assign_x,in_not_assign_x]) or
  4903. ((inlinenumber = in_assert_x_y) and
  4904. (cs_do_assertion in localswitches));
  4905. end;
  4906. function tinlinenode.first_fma: tnode;
  4907. begin
  4908. CGMessage1(cg_e_function_not_support_by_selected_instruction_set,'FMA');
  4909. result:=nil;
  4910. end;
  4911. //
  4912. //||||||| .merge-left.r31134
  4913. //
  4914. //{$ifdef ARM}
  4915. // {$i armtype.inc}
  4916. //{$endif ARM}
  4917. //=======
  4918. //
  4919. //{$ifdef x86}
  4920. // {$i x86type.inc}
  4921. //{$endif x86}
  4922. //{$ifdef ARM}
  4923. // {$i armtype.inc}
  4924. //{$endif ARM}
  4925. {$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
  4926. function tinlinenode.first_ShiftRot_assign_64bitint: tnode;
  4927. var
  4928. procname: string[31];
  4929. begin
  4930. {$ifdef cpucg64shiftsupport}
  4931. if inlinenumber in [in_sar_assign_x_y,in_shl_assign_x_y,in_shr_assign_x_y] then
  4932. begin
  4933. result:=nil;
  4934. expectloc:=tcallparanode(tcallparanode(left).right).left.expectloc;
  4935. exit;
  4936. end;
  4937. {$endif cpucg64shiftsupport}
  4938. result := nil;
  4939. if is_signed(tcallparanode(left).right.resultdef) then
  4940. procname:='int64'
  4941. else
  4942. procname:='qword';
  4943. case inlinenumber of
  4944. in_sar_assign_x_y:
  4945. procname := 'fpc_sar_assign_'+procname;
  4946. in_shl_assign_x_y:
  4947. procname := 'fpc_shl_assign_'+procname;
  4948. in_shr_assign_x_y:
  4949. procname := 'fpc_shr_assign_'+procname;
  4950. in_rol_assign_x_y:
  4951. procname := 'fpc_rol_assign_'+procname;
  4952. in_ror_assign_x_y:
  4953. procname := 'fpc_ror_assign_'+procname;
  4954. else
  4955. internalerror(2017041301);
  4956. end;
  4957. result := ccallnode.createintern(procname,ccallparanode.create(tcallparanode(left).left,
  4958. ccallparanode.create(tcallparanode(tcallparanode(left).right).left,nil)));
  4959. tcallparanode(tcallparanode(left).right).left := nil;
  4960. tcallparanode(left).left := nil;
  4961. firstpass(result);
  4962. end;
  4963. {$endif not cpu64bitalu and nto cpuhighleveltarget}
  4964. function tinlinenode.first_AndOrXorShiftRot_assign: tnode;
  4965. begin
  4966. {$if not defined(cpu64bitalu) and not defined(cpuhighleveltarget)}
  4967. { 64 bit ints have their own shift handling }
  4968. if is_64bit(tcallparanode(left).right.resultdef) and
  4969. (inlinenumber in [in_sar_assign_x_y,in_shl_assign_x_y,in_shr_assign_x_y,in_rol_assign_x_y,in_ror_assign_x_y]) then
  4970. result := first_ShiftRot_assign_64bitint
  4971. else
  4972. {$endif not cpu64bitalu and not cpuhighleveltarget}
  4973. begin
  4974. result:=nil;
  4975. expectloc:=tcallparanode(tcallparanode(left).right).left.expectloc;
  4976. end;
  4977. end;
  4978. function tinlinenode.first_NegNot_assign: tnode;
  4979. begin
  4980. result:=nil;
  4981. expectloc:=left.expectloc;
  4982. end;
  4983. function tinlinenode.first_cpu : tnode;
  4984. begin
  4985. Result:=nil;
  4986. internalerror(2017110101);
  4987. end;
  4988. procedure tinlinenode.CheckParameters(count: integer);
  4989. var
  4990. p: tnode;
  4991. begin
  4992. if count=1 then
  4993. set_varstate(left,vs_read,[vsf_must_be_valid])
  4994. else
  4995. begin
  4996. p:=left;
  4997. while count>0 do
  4998. begin
  4999. set_varstate(tcallparanode(p).left,vs_read,[vsf_must_be_valid]);
  5000. p:=tcallparanode(p).right;
  5001. dec(count);
  5002. end;
  5003. end;
  5004. end;
  5005. end.