ncal.pas 176 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253
  1. {
  2. This file implements the node for sub procedure calling.
  3. Copyright (c) 1998-2002 by Florian Klaempfl
  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 ncal;
  18. {$i fpcdefs.inc}
  19. { $define DEBUGINLINE}
  20. interface
  21. uses
  22. cutils,cclasses,
  23. globtype,constexp,
  24. paramgr,parabase,cgbase,
  25. node,nbas,nutils,
  26. {$ifdef state_tracking}
  27. nstate,
  28. {$endif state_tracking}
  29. symbase,symtype,symsym,symdef,symtable;
  30. type
  31. tcallnodeflag = (
  32. cnf_typedefset,
  33. cnf_return_value_used,
  34. cnf_do_inline,
  35. cnf_inherited,
  36. cnf_anon_inherited,
  37. cnf_new_call,
  38. cnf_dispose_call,
  39. cnf_member_call, { called with implicit methodpointer tree }
  40. cnf_uses_varargs, { varargs are used in the declaration }
  41. cnf_create_failed, { exception thrown in constructor -> don't call beforedestruction }
  42. cnf_objc_processed, { the procedure name has been set to the appropriate objc_msgSend* variant -> don't process again }
  43. cnf_objc_id_call, { the procedure is a member call via id -> any ObjC method of any ObjC type in scope is fair game }
  44. cnf_unit_specified, { the unit in which the procedure has to be searched has been specified }
  45. cnf_call_never_returns { information for the dfa that a subroutine never returns }
  46. );
  47. tcallnodeflags = set of tcallnodeflag;
  48. tcallparanode = class;
  49. tcallnode = class(tbinarynode)
  50. private
  51. { number of parameters passed from the source, this does not include the hidden parameters }
  52. paralength : smallint;
  53. function is_simple_para_load(p:tnode; may_be_in_reg: boolean):boolean;
  54. procedure maybe_load_in_temp(var p:tnode);
  55. function gen_high_tree(var p:tnode;paradef:tdef):tnode;
  56. function gen_procvar_context_tree_self:tnode;
  57. function gen_procvar_context_tree_parentfp:tnode;
  58. function gen_self_tree:tnode;
  59. function gen_vmt_tree:tnode;
  60. function gen_block_context:tnode;
  61. procedure gen_hidden_parameters;
  62. function funcret_can_be_reused:boolean;
  63. procedure maybe_create_funcret_node;
  64. procedure bind_parasym;
  65. procedure add_init_statement(n:tnode);
  66. procedure add_done_statement(n:tnode);
  67. procedure convert_carg_array_of_const;
  68. procedure order_parameters;
  69. procedure check_inlining;
  70. function pass1_normal:tnode;
  71. procedure register_created_object_types;
  72. function get_expect_loc: tcgloc;
  73. protected
  74. procedure gen_syscall_para(para: tcallparanode); virtual;
  75. procedure objc_convert_to_message_send;virtual;
  76. protected
  77. { inlining support }
  78. inlinelocals : TFPObjectList;
  79. inlineinitstatement,
  80. inlinecleanupstatement : tstatementnode;
  81. procedure createinlineparas;
  82. procedure wrapcomplexinlinepara(para: tcallparanode); virtual;
  83. function replaceparaload(var n: tnode; arg: pointer): foreachnoderesult;
  84. procedure createlocaltemps(p:TObject;arg:pointer);
  85. function optimize_funcret_assignment(inlineblock: tblocknode): tnode;
  86. function pass1_inline:tnode;
  87. protected
  88. pushedparasize : longint;
  89. { Objective-C support: force the call node to call the routine with
  90. this name rather than the name of symtableprocentry (don't store
  91. to ppu, is set while processing the node). Also used on the JVM
  92. target for calling virtual methods, as this is name-based and not
  93. based on VMT entry locations }
  94. {$ifdef symansistr}
  95. fforcedprocname: TSymStr;
  96. {$else symansistr}
  97. fforcedprocname: pshortstring;
  98. {$endif symansistr}
  99. public
  100. { the symbol containing the definition of the procedure }
  101. { to call }
  102. symtableprocentry : tprocsym;
  103. symtableprocentryderef : tderef;
  104. { symtable where the entry was found, needed for with support }
  105. symtableproc : TSymtable;
  106. { the definition of the procedure to call }
  107. procdefinition : tabstractprocdef;
  108. procdefinitionderef : tderef;
  109. { tree that contains the pointer to the object for this method }
  110. methodpointer : tnode;
  111. { initialize/finalization of temps }
  112. callinitblock,
  113. callcleanupblock : tblocknode;
  114. { function return node for initialized types or supplied return variable.
  115. When the result is passed in a parameter then it is set to nil }
  116. funcretnode : tnode;
  117. { varargs parasyms }
  118. varargsparas : tvarargsparalist;
  119. { separately specified resultdef for some compilerprocs (e.g. }
  120. { you can't have a function with an "array of char" resultdef }
  121. { the RTL) (JM) }
  122. typedef: tdef;
  123. callnodeflags : tcallnodeflags;
  124. { only the processor specific nodes need to override this }
  125. { constructor }
  126. constructor create(l:tnode; v : tprocsym;st : TSymtable; mp: tnode; callflags:tcallnodeflags);virtual;
  127. constructor create_procvar(l,r:tnode);
  128. constructor createintern(const name: string; params: tnode);
  129. constructor createinternfromunit(const fromunit, procname: string; params: tnode);
  130. constructor createinternres(const name: string; params: tnode; res:tdef);
  131. constructor createinternresfromunit(const fromunit, procname: string; params: tnode; res:tdef);
  132. constructor createinternreturn(const name: string; params: tnode; returnnode : tnode);
  133. constructor createinternmethod(mp: tnode; const name: string; params: tnode);
  134. constructor createinternmethodres(mp: tnode; const name: string; params: tnode; res:tdef);
  135. destructor destroy;override;
  136. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  137. procedure ppuwrite(ppufile:tcompilerppufile);override;
  138. procedure buildderefimpl;override;
  139. procedure derefimpl;override;
  140. function dogetcopy : tnode;override;
  141. { Goes through all symbols in a class and subclasses and calls
  142. verify abstract for each .
  143. }
  144. procedure verifyabstractcalls;
  145. { called for each definition in a class and verifies if a method
  146. is abstract or not, if it is abstract, give out a warning
  147. }
  148. procedure verifyabstract(sym:TObject;arg:pointer);
  149. procedure insertintolist(l : tnodelist);override;
  150. function pass_1 : tnode;override;
  151. function pass_typecheck:tnode;override;
  152. {$ifdef state_tracking}
  153. function track_state_pass(exec_known:boolean):boolean;override;
  154. {$endif state_tracking}
  155. function docompare(p: tnode): boolean; override;
  156. procedure printnodedata(var t:text);override;
  157. function para_count:longint;
  158. function required_para_count:longint;
  159. { checks if there are any parameters which end up at the stack, i.e.
  160. which have LOC_REFERENCE and set pi_has_stackparameter if this applies }
  161. procedure check_stack_parameters;
  162. { force the name of the to-be-called routine to a particular string,
  163. used for Objective-C message sending. }
  164. property parameters : tnode read left write left;
  165. property pushed_parasize: longint read pushedparasize;
  166. private
  167. AbstractMethodsList : TFPHashList;
  168. end;
  169. tcallnodeclass = class of tcallnode;
  170. tcallparaflag = (
  171. cpf_is_colon_para,
  172. cpf_varargs_para { belongs this para to varargs }
  173. );
  174. tcallparaflags = set of tcallparaflag;
  175. tcallparanode = class(ttertiarynode)
  176. private
  177. fcontains_stack_tainting_call_cached,
  178. ffollowed_by_stack_tainting_call_cached : boolean;
  179. protected
  180. { in case of copy-out parameters: initialization code, and the code to
  181. copy back the parameter value after the call (including any required
  182. finalization code }
  183. fparainit,
  184. fparacopyback: tnode;
  185. procedure handlemanagedbyrefpara(orgparadef: tdef);virtual;abstract;
  186. public
  187. callparaflags : tcallparaflags;
  188. parasym : tparavarsym;
  189. { only the processor specific nodes need to override this }
  190. { constructor }
  191. constructor create(expr,next : tnode);virtual;
  192. destructor destroy;override;
  193. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  194. procedure ppuwrite(ppufile:tcompilerppufile);override;
  195. procedure buildderefimpl; override;
  196. procedure derefimpl; override;
  197. function dogetcopy : tnode;override;
  198. procedure insertintolist(l : tnodelist);override;
  199. function pass_typecheck : tnode;override;
  200. function pass_1 : tnode;override;
  201. procedure get_paratype;
  202. procedure firstcallparan;
  203. procedure insert_typeconv;
  204. procedure secondcallparan;virtual;abstract;
  205. function docompare(p: tnode): boolean; override;
  206. procedure printnodetree(var t:text);override;
  207. { returns whether a parameter contains a type conversion from }
  208. { a refcounted into a non-refcounted type }
  209. function can_be_inlined: boolean;
  210. property paravalue : tnode read left write left;
  211. property nextpara : tnode read right write right;
  212. { third is reused to store the parameter name (only while parsing
  213. vardispatch calls, never in real node tree) and copy of 'high'
  214. parameter tree when the parameter is an open array of managed type }
  215. property parametername : tnode read third write third;
  216. { returns whether the evaluation of this parameter involves a
  217. stack tainting call }
  218. function contains_stack_tainting_call: boolean;
  219. { initialises the fcontains_stack_tainting_call_cached field with the
  220. result of contains_stack_tainting_call so that it can be quickly
  221. accessed via the contains_stack_tainting_call_cached property }
  222. procedure init_contains_stack_tainting_call_cache;
  223. { returns result of contains_stack_tainting_call cached during last
  224. call to init_contains_stack_tainting_call_cache }
  225. property contains_stack_tainting_call_cached: boolean read fcontains_stack_tainting_call_cached;
  226. { returns whether this parameter is followed by at least one other
  227. parameter whose evaluation involves a stack tainting parameter
  228. (result is only valid after order_parameters has been called) }
  229. property followed_by_stack_tainting_call_cached: boolean read ffollowed_by_stack_tainting_call_cached;
  230. property paracopyback: tnode read fparacopyback;
  231. end;
  232. tcallparanodeclass = class of tcallparanode;
  233. tdispcalltype = (
  234. dct_method,
  235. dct_propget,
  236. dct_propput
  237. );
  238. function reverseparameters(p: tcallparanode): tcallparanode;
  239. function translate_disp_call(selfnode,parametersnode: tnode; calltype: tdispcalltype; const methodname : ansistring;
  240. dispid : longint;resultdef : tdef) : tnode;
  241. var
  242. ccallnode : tcallnodeclass = tcallnode;
  243. ccallparanode : tcallparanodeclass = tcallparanode;
  244. { Current callnode, this is needed for having a link
  245. between the callparanodes and the callnode they belong to }
  246. aktcallnode : tcallnode;
  247. implementation
  248. uses
  249. systems,
  250. verbose,globals,
  251. symconst,defutil,defcmp,
  252. htypechk,pass_1,
  253. ncnv,nld,ninl,nadd,ncon,nmem,nset,nobjc,
  254. ngenutil,objcutil,
  255. procinfo,cpuinfo,
  256. wpobase;
  257. type
  258. tobjectinfoitem = class(tlinkedlistitem)
  259. objinfo : tobjectdef;
  260. constructor create(def : tobjectdef);
  261. end;
  262. {****************************************************************************
  263. HELPERS
  264. ****************************************************************************}
  265. function reverseparameters(p: tcallparanode): tcallparanode;
  266. var
  267. hp1, hp2: tcallparanode;
  268. begin
  269. hp1:=nil;
  270. while assigned(p) do
  271. begin
  272. { pull out }
  273. hp2:=p;
  274. p:=tcallparanode(p.right);
  275. { pull in }
  276. hp2.right:=hp1;
  277. hp1:=hp2;
  278. end;
  279. reverseparameters:=hp1;
  280. end;
  281. function translate_disp_call(selfnode,parametersnode: tnode; calltype: tdispcalltype; const methodname : ansistring;
  282. dispid : longint;resultdef : tdef) : tnode;
  283. const
  284. DISPATCH_METHOD = $1;
  285. DISPATCH_PROPERTYGET = $2;
  286. DISPATCH_PROPERTYPUT = $4;
  287. DISPATCH_PROPERTYPUTREF = $8;
  288. DISPATCH_CONSTRUCT = $4000;
  289. calltypes: array[tdispcalltype] of byte = (
  290. DISPATCH_METHOD, DISPATCH_PROPERTYGET, DISPATCH_PROPERTYPUT
  291. );
  292. var
  293. statements : tstatementnode;
  294. result_data,
  295. params : ttempcreatenode;
  296. paramssize : cardinal;
  297. calldescnode : tdataconstnode;
  298. resultvalue : tnode;
  299. para : tcallparanode;
  300. namedparacount,
  301. paracount : longint;
  302. assignmenttype,
  303. vardatadef,
  304. pvardatadef : tdef;
  305. useresult: boolean;
  306. restype: byte;
  307. names : ansistring;
  308. variantdispatch : boolean;
  309. function is_byref_para(out assign_type: tdef): boolean;
  310. begin
  311. result:=(assigned(para.parasym) and (para.parasym.varspez in [vs_var,vs_out,vs_constref])) or
  312. (variantdispatch and valid_for_var(para.left,false));
  313. if result or (para.left.resultdef.typ in [variantdef]) then
  314. assign_type:=voidpointertype
  315. else
  316. case para.left.resultdef.size of
  317. 1..4:
  318. assign_type:=u32inttype;
  319. 8:
  320. assign_type:=u64inttype;
  321. else
  322. internalerror(2007042801);
  323. end;
  324. end;
  325. function getvardef(sourcedef: TDef): longint;
  326. begin
  327. if is_ansistring(sourcedef) then
  328. result:=varStrArg
  329. else
  330. if is_unicodestring(sourcedef) then
  331. result:=varUStrArg
  332. else
  333. if is_interfacecom_or_dispinterface(sourcedef) then
  334. begin
  335. { distinct IDispatch and IUnknown interfaces }
  336. if def_is_related(tobjectdef(sourcedef),tobjectdef(search_system_type('IDISPATCH').typedef)) then
  337. result:=vardispatch
  338. else
  339. result:=varunknown;
  340. end
  341. else
  342. result:=sourcedef.getvardef;
  343. end;
  344. begin
  345. variantdispatch:=selfnode.resultdef.typ=variantdef;
  346. result:=internalstatements(statements);
  347. result_data:=nil;
  348. useresult := assigned(resultdef) and not is_void(resultdef);
  349. if useresult then
  350. begin
  351. { get temp for the result }
  352. result_data:=ctempcreatenode.create(colevarianttype,colevarianttype.size,tt_persistent,true);
  353. addstatement(statements,result_data);
  354. end;
  355. { first, count and check parameters }
  356. para:=tcallparanode(parametersnode);
  357. paracount:=0;
  358. namedparacount:=0;
  359. while assigned(para) do
  360. begin
  361. typecheckpass(para.left);
  362. { skip hidden dispinterface parameters like $self, $result,
  363. but count skipped variantdispatch parameters. }
  364. if (not variantdispatch) and (para.left.nodetype=nothingn) then
  365. begin
  366. para:=tcallparanode(para.nextpara);
  367. continue;
  368. end;
  369. inc(paracount);
  370. if assigned(para.parametername) then
  371. inc(namedparacount);
  372. { insert some extra casts }
  373. if para.left.nodetype=stringconstn then
  374. inserttypeconv_internal(para.left,cwidestringtype)
  375. { force automatable boolean type }
  376. else if is_boolean(para.left.resultdef) then
  377. inserttypeconv_internal(para.left,bool16type)
  378. { force automatable float type }
  379. else if is_extended(para.left.resultdef)
  380. and (current_settings.fputype<>fpu_none) then
  381. inserttypeconv_internal(para.left,s64floattype)
  382. else if is_shortstring(para.left.resultdef) then
  383. inserttypeconv_internal(para.left,cwidestringtype)
  384. { skip this check if we've already typecasted to automatable type }
  385. else if (para.left.nodetype<>nothingn) and (not is_automatable(para.left.resultdef)) then
  386. CGMessagePos1(para.left.fileinfo,type_e_not_automatable,para.left.resultdef.typename);
  387. para:=tcallparanode(para.nextpara);
  388. end;
  389. { create a temp to store parameter values }
  390. params:=ctempcreatenode.create(cformaltype,0,tt_persistent,false);
  391. addstatement(statements,params);
  392. calldescnode:=cdataconstnode.create;
  393. if not variantdispatch then { generate a tdispdesc record }
  394. begin
  395. { dispid }
  396. calldescnode.append(dispid,sizeof(dispid));
  397. { restype }
  398. if useresult then
  399. restype:=getvardef(resultdef)
  400. else
  401. restype:=0;
  402. calldescnode.appendbyte(restype);
  403. end;
  404. calldescnode.appendbyte(calltypes[calltype]);
  405. calldescnode.appendbyte(paracount);
  406. calldescnode.appendbyte(namedparacount);
  407. { build up parameters and description }
  408. para:=tcallparanode(parametersnode);
  409. paramssize:=0;
  410. names := '';
  411. while assigned(para) do
  412. begin
  413. { Skipped parameters are actually (varType=varError, vError=DISP_E_PARAMNOTFOUND).
  414. Generate only varType here, the value will be added by RTL. }
  415. if para.left.nodetype=nothingn then
  416. begin
  417. if variantdispatch then
  418. calldescnode.appendbyte(varError);
  419. para:=tcallparanode(para.nextpara);
  420. continue;
  421. end;
  422. if assigned(para.parametername) then
  423. begin
  424. if para.parametername.nodetype=stringconstn then
  425. names:=names+tstringconstnode(para.parametername).value_str+#0
  426. else
  427. internalerror(200611041);
  428. end;
  429. restype:=getvardef(para.left.resultdef);
  430. if is_byref_para(assignmenttype) then
  431. restype:=restype or $80;
  432. { assign the argument/parameter to the temporary location }
  433. { for Variants, we always pass a pointer, RTL helpers must handle it
  434. depending on byref bit }
  435. if assignmenttype=voidpointertype then
  436. addstatement(statements,cassignmentnode.create(
  437. ctypeconvnode.create_internal(ctemprefnode.create_offset(params,paramssize),
  438. voidpointertype),
  439. ctypeconvnode.create_internal(caddrnode.create_internal(para.left),voidpointertype)))
  440. else
  441. addstatement(statements,cassignmentnode.create(
  442. ctypeconvnode.create_internal(ctemprefnode.create_offset(params,paramssize),
  443. assignmenttype),
  444. ctypeconvnode.create_internal(para.left,assignmenttype)));
  445. inc(paramssize,max(voidpointertype.size,assignmenttype.size));
  446. calldescnode.appendbyte(restype);
  447. para.left:=nil;
  448. para:=tcallparanode(para.nextpara);
  449. end;
  450. { Set final size for parameter block }
  451. params.size:=paramssize;
  452. { old argument list skeleton isn't needed anymore }
  453. parametersnode.free;
  454. pvardatadef:=tpointerdef(search_system_type('PVARDATA').typedef);
  455. if useresult then
  456. resultvalue:=caddrnode.create(ctemprefnode.create(result_data))
  457. else
  458. resultvalue:=cpointerconstnode.create(0,voidpointertype);
  459. if variantdispatch then
  460. begin
  461. calldescnode.append(pointer(methodname)^,length(methodname));
  462. calldescnode.appendbyte(0);
  463. calldescnode.append(pointer(names)^,length(names));
  464. { actual call }
  465. vardatadef:=trecorddef(search_system_type('TVARDATA').typedef);
  466. addstatement(statements,ccallnode.createintern('fpc_dispinvoke_variant',
  467. { parameters are passed always reverted, i.e. the last comes first }
  468. ccallparanode.create(caddrnode.create(ctemprefnode.create(params)),
  469. ccallparanode.create(caddrnode.create(calldescnode),
  470. ccallparanode.create(ctypeconvnode.create_internal(selfnode,vardatadef),
  471. ccallparanode.create(ctypeconvnode.create_internal(resultvalue,pvardatadef),nil)))))
  472. );
  473. end
  474. else
  475. begin
  476. addstatement(statements,ccallnode.createintern('fpc_dispatch_by_id',
  477. { parameters are passed always reverted, i.e. the last comes first }
  478. ccallparanode.create(caddrnode.create(ctemprefnode.create(params)),
  479. ccallparanode.create(caddrnode.create(calldescnode),
  480. ccallparanode.create(ctypeconvnode.create_internal(selfnode,voidpointertype),
  481. ccallparanode.create(ctypeconvnode.create_internal(resultvalue,pvardatadef),nil)))))
  482. );
  483. end;
  484. addstatement(statements,ctempdeletenode.create(params));
  485. if useresult then
  486. begin
  487. { clean up }
  488. addstatement(statements,ctempdeletenode.create_normal_temp(result_data));
  489. addstatement(statements,ctemprefnode.create(result_data));
  490. end;
  491. end;
  492. {****************************************************************************
  493. TOBJECTINFOITEM
  494. ****************************************************************************}
  495. constructor tobjectinfoitem.create(def : tobjectdef);
  496. begin
  497. inherited create;
  498. objinfo := def;
  499. end;
  500. {****************************************************************************
  501. TCALLPARANODE
  502. ****************************************************************************}
  503. constructor tcallparanode.create(expr,next : tnode);
  504. begin
  505. inherited create(callparan,expr,next,nil);
  506. if not assigned(expr) then
  507. internalerror(200305091);
  508. expr.fileinfo:=fileinfo;
  509. callparaflags:=[];
  510. if expr.nodetype = typeconvn then
  511. ttypeconvnode(expr).warn_pointer_to_signed:=false;
  512. end;
  513. destructor tcallparanode.destroy;
  514. begin
  515. fparainit.free;
  516. fparacopyback.free;
  517. inherited destroy;
  518. end;
  519. constructor tcallparanode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  520. begin
  521. inherited ppuload(t,ppufile);
  522. ppufile.getsmallset(callparaflags);
  523. fparainit:=ppuloadnode(ppufile);
  524. fparacopyback:=ppuloadnode(ppufile);
  525. end;
  526. procedure tcallparanode.ppuwrite(ppufile:tcompilerppufile);
  527. begin
  528. inherited ppuwrite(ppufile);
  529. ppufile.putsmallset(callparaflags);
  530. ppuwritenode(ppufile,fparainit);
  531. ppuwritenode(ppufile,fparacopyback);
  532. end;
  533. procedure tcallparanode.buildderefimpl;
  534. begin
  535. inherited buildderefimpl;
  536. if assigned(fparainit) then
  537. fparainit.buildderefimpl;
  538. if assigned(fparacopyback) then
  539. fparacopyback.buildderefimpl;
  540. end;
  541. procedure tcallparanode.derefimpl;
  542. begin
  543. inherited derefimpl;
  544. if assigned(fparainit) then
  545. fparainit.derefimpl;
  546. if assigned(fparacopyback) then
  547. fparacopyback.derefimpl;
  548. end;
  549. function tcallparanode.dogetcopy : tnode;
  550. var
  551. n : tcallparanode;
  552. initcopy: tnode;
  553. begin
  554. initcopy:=nil;
  555. { must be done before calling inherited getcopy, because can create
  556. tempcreatenodes for values used in left }
  557. if assigned(fparainit) then
  558. initcopy:=fparainit.getcopy;
  559. n:=tcallparanode(inherited dogetcopy);
  560. n.callparaflags:=callparaflags;
  561. n.parasym:=parasym;
  562. n.fparainit:=initcopy;
  563. if assigned(fparacopyback) then
  564. n.fparacopyback:=fparacopyback.getcopy;
  565. result:=n;
  566. end;
  567. procedure tcallparanode.insertintolist(l : tnodelist);
  568. begin
  569. end;
  570. function tcallparanode.pass_typecheck : tnode;
  571. begin
  572. { need to use get_paratype }
  573. internalerror(200709251);
  574. result:=nil;
  575. end;
  576. function tcallparanode.pass_1 : tnode;
  577. begin
  578. { need to use firstcallparan }
  579. internalerror(200709252);
  580. result:=nil;
  581. end;
  582. procedure tcallparanode.get_paratype;
  583. var
  584. old_array_constructor : boolean;
  585. begin
  586. if assigned(right) then
  587. tcallparanode(right).get_paratype;
  588. old_array_constructor:=allow_array_constructor;
  589. allow_array_constructor:=true;
  590. if assigned(fparainit) then
  591. typecheckpass(fparainit);
  592. typecheckpass(left);
  593. if assigned(third) then
  594. typecheckpass(third);
  595. if assigned(fparacopyback) then
  596. typecheckpass(fparacopyback);
  597. allow_array_constructor:=old_array_constructor;
  598. if codegenerror then
  599. resultdef:=generrordef
  600. else
  601. resultdef:=left.resultdef;
  602. end;
  603. procedure tcallparanode.firstcallparan;
  604. begin
  605. if assigned(right) then
  606. tcallparanode(right).firstcallparan;
  607. if not assigned(left.resultdef) then
  608. get_paratype;
  609. if assigned(parasym) and
  610. (target_info.system in systems_managed_vm) and
  611. (parasym.varspez in [vs_var,vs_out,vs_constref]) and
  612. (parasym.vardef.typ<>formaldef) and
  613. { for record constructors }
  614. (left.nodetype<>nothingn) then
  615. handlemanagedbyrefpara(left.resultdef);
  616. { does it need to load RTTI? }
  617. if assigned(parasym) and (parasym.varspez=vs_out) and
  618. (cs_create_pic in current_settings.moduleswitches) and
  619. (
  620. is_rtti_managed_type(left.resultdef) or
  621. (
  622. is_open_array(resultdef) and
  623. is_managed_type(tarraydef(resultdef).elementdef)
  624. )
  625. ) and
  626. not(target_info.system in systems_garbage_collected_managed_types) then
  627. include(current_procinfo.flags,pi_needs_got);
  628. if assigned(fparainit) then
  629. firstpass(fparainit);
  630. firstpass(left);
  631. if assigned(fparacopyback) then
  632. firstpass(fparacopyback);
  633. if assigned(third) then
  634. firstpass(third);
  635. expectloc:=left.expectloc;
  636. end;
  637. procedure tcallparanode.insert_typeconv;
  638. var
  639. olddef : tdef;
  640. hp : tnode;
  641. block : tblocknode;
  642. statements : tstatementnode;
  643. temp : ttempcreatenode;
  644. owningprocdef: tprocdef;
  645. begin
  646. { Be sure to have the resultdef }
  647. if not assigned(left.resultdef) then
  648. typecheckpass(left);
  649. if (left.nodetype<>nothingn) then
  650. begin
  651. { convert loads of the function result variable into procvars
  652. representing the current function in case the formal parameter is
  653. a procvar (CodeWarrior Pascal contains the same kind of
  654. automatic disambiguation; you can use the function name in both
  655. meanings, so we cannot statically pick either the function result
  656. or the function definition in pexpr) }
  657. if (m_mac in current_settings.modeswitches) and
  658. (parasym.vardef.typ=procvardef) and
  659. is_ambiguous_funcret_load(left,owningprocdef) then
  660. begin
  661. hp:=cloadnode.create_procvar(owningprocdef.procsym,owningprocdef,owningprocdef.procsym.owner);
  662. typecheckpass(hp);
  663. left.free;
  664. left:=hp;
  665. end;
  666. { Convert tp procvars, this is needs to be done
  667. here to make the change permanent. in the overload
  668. choosing the changes are only made temporarily }
  669. if (left.resultdef.typ=procvardef) and
  670. not(parasym.vardef.typ in [procvardef,formaldef]) then
  671. begin
  672. if maybe_call_procvar(left,true) then
  673. resultdef:=left.resultdef
  674. end;
  675. { Remove implicitly inserted typecast to pointer for
  676. @procvar in macpas }
  677. if (m_mac_procvar in current_settings.modeswitches) and
  678. (parasym.vardef.typ=procvardef) and
  679. (left.nodetype=typeconvn) and
  680. is_voidpointer(left.resultdef) and
  681. (ttypeconvnode(left).left.nodetype=typeconvn) and
  682. (ttypeconvnode(ttypeconvnode(left).left).convtype=tc_proc_2_procvar) then
  683. begin
  684. hp:=left;
  685. left:=ttypeconvnode(left).left;
  686. ttypeconvnode(hp).left:=nil;
  687. hp.free;
  688. end;
  689. maybe_global_proc_to_nested(left,parasym.vardef);
  690. { Handle varargs and hidden paras directly, no typeconvs or }
  691. { pass_typechecking needed }
  692. if (cpf_varargs_para in callparaflags) then
  693. begin
  694. { this should only happen vor C varargs }
  695. { the necessary conversions have already been performed in }
  696. { tarrayconstructornode.insert_typeconvs }
  697. set_varstate(left,vs_read,[vsf_must_be_valid]);
  698. insert_varargstypeconv(left,true);
  699. resultdef:=left.resultdef;
  700. { also update parasym type to get the correct parameter location
  701. for the new types }
  702. parasym.vardef:=left.resultdef;
  703. end
  704. else
  705. if (vo_is_hidden_para in parasym.varoptions) then
  706. begin
  707. set_varstate(left,vs_read,[vsf_must_be_valid]);
  708. resultdef:=left.resultdef;
  709. end
  710. else
  711. begin
  712. { Do we need arrayconstructor -> set conversion, then insert
  713. it here before the arrayconstructor node breaks the tree
  714. with its conversions of enum->ord }
  715. if (left.nodetype=arrayconstructorn) and
  716. (parasym.vardef.typ=setdef) then
  717. inserttypeconv(left,parasym.vardef);
  718. { set some settings needed for arrayconstructor }
  719. if is_array_constructor(left.resultdef) then
  720. begin
  721. if left.nodetype<>arrayconstructorn then
  722. internalerror(200504041);
  723. if is_array_of_const(parasym.vardef) then
  724. begin
  725. { force variant array }
  726. include(left.flags,nf_forcevaria);
  727. end
  728. else
  729. begin
  730. include(left.flags,nf_novariaallowed);
  731. { now that the resultting type is know we can insert the required
  732. typeconvs for the array constructor }
  733. if parasym.vardef.typ=arraydef then
  734. tarrayconstructornode(left).force_type(tarraydef(parasym.vardef).elementdef);
  735. end;
  736. end;
  737. { check if local proc/func is assigned to procvar }
  738. if left.resultdef.typ=procvardef then
  739. test_local_to_procvar(tprocvardef(left.resultdef),parasym.vardef);
  740. { test conversions }
  741. if not(is_shortstring(left.resultdef) and
  742. is_shortstring(parasym.vardef)) and
  743. (parasym.vardef.typ<>formaldef) and
  744. not(parasym.univpara) then
  745. begin
  746. { Process open parameters }
  747. if paramanager.keep_para_array_range(parasym.varspez,parasym.vardef,aktcallnode.procdefinition.proccalloption) then
  748. begin
  749. { insert type conv but hold the ranges of the array }
  750. olddef:=left.resultdef;
  751. inserttypeconv(left,parasym.vardef);
  752. left.resultdef:=olddef;
  753. end
  754. else
  755. begin
  756. check_ranges(left.fileinfo,left,parasym.vardef);
  757. inserttypeconv(left,parasym.vardef);
  758. end;
  759. if codegenerror then
  760. exit;
  761. end;
  762. { truncate shortstring value parameters at the caller side if }
  763. { they are passed by value (if passed by reference, then the }
  764. { callee will truncate when copying in the string) }
  765. { This happens e.g. on x86_64 for small strings }
  766. if is_shortstring(left.resultdef) and
  767. is_shortstring(parasym.vardef) and
  768. (parasym.varspez=vs_value) and
  769. not paramanager.push_addr_param(parasym.varspez,parasym.vardef,
  770. aktcallnode.procdefinition.proccalloption) and
  771. ((is_open_string(left.resultdef) and
  772. (tstringdef(parasym.vardef).len < 255)) or
  773. (not is_open_string(left.resultdef) and
  774. { when a stringconstn is typeconverted, then only its }
  775. { def is modified, not the contents (needed because in }
  776. { Delphi/TP, if you pass a longer string to a const }
  777. { parameter, then the callee has to see this longer }
  778. { string) }
  779. (((left.nodetype<>stringconstn) and
  780. (tstringdef(parasym.vardef).len<tstringdef(left.resultdef).len)) or
  781. ((left.nodetype=stringconstn) and
  782. (tstringdef(parasym.vardef).len<tstringconstnode(left).len))))) then
  783. begin
  784. block:=internalstatements(statements);
  785. { temp for the new string }
  786. temp:=ctempcreatenode.create(parasym.vardef,parasym.vardef.size,
  787. tt_persistent,true);
  788. addstatement(statements,temp);
  789. { assign parameter to temp }
  790. addstatement(statements,cassignmentnode.create(ctemprefnode.create(temp),left));
  791. left:=nil;
  792. { release temp after next use }
  793. addstatement(statements,ctempdeletenode.create_normal_temp(temp));
  794. addstatement(statements,ctemprefnode.create(temp));
  795. typecheckpass(tnode(block));
  796. left:=block;
  797. end;
  798. { check var strings }
  799. if (cs_strict_var_strings in current_settings.localswitches) and
  800. is_shortstring(left.resultdef) and
  801. is_shortstring(parasym.vardef) and
  802. (parasym.varspez in [vs_out,vs_var,vs_constref]) and
  803. not(is_open_string(parasym.vardef)) and
  804. not(equal_defs(left.resultdef,parasym.vardef)) then
  805. begin
  806. CGMessagePos(left.fileinfo,type_e_strict_var_string_violation);
  807. end;
  808. { passing a value to an "univ" parameter implies an explicit
  809. typecast to the parameter type. Must be done before the
  810. valid_for_var() check, since the typecast can result in
  811. an invalid lvalue in case of var/out parameters. }
  812. if (parasym.univpara) then
  813. begin
  814. { load procvar if a procedure is passed }
  815. if ((m_tp_procvar in current_settings.modeswitches) or
  816. (m_mac_procvar in current_settings.modeswitches)) and
  817. (left.nodetype=calln) and
  818. (is_void(left.resultdef)) then
  819. begin
  820. load_procvar_from_calln(left);
  821. { load_procvar_from_calln() creates a loadn for a
  822. a procedure, which means that the type conversion
  823. below will type convert the first instruction
  824. bytes of the procedure -> convert to a procvar }
  825. left:=ctypeconvnode.create_proc_to_procvar(left);
  826. typecheckpass(left);
  827. end;
  828. inserttypeconv_explicit(left,parasym.vardef);
  829. end;
  830. { Handle formal parameters separate }
  831. if (parasym.vardef.typ=formaldef) then
  832. begin
  833. { load procvar if a procedure is passed }
  834. if ((m_tp_procvar in current_settings.modeswitches) or
  835. (m_mac_procvar in current_settings.modeswitches)) and
  836. (left.nodetype=calln) and
  837. (is_void(left.resultdef)) then
  838. load_procvar_from_calln(left);
  839. case parasym.varspez of
  840. vs_var,
  841. vs_constref,
  842. vs_out :
  843. begin
  844. if not valid_for_formal_var(left,true) then
  845. CGMessagePos(left.fileinfo,parser_e_illegal_parameter_list)
  846. else if (target_info.system in systems_managed_vm) then
  847. handlemanagedbyrefpara(left.resultdef);
  848. end;
  849. vs_const :
  850. begin
  851. if not valid_for_formal_const(left,true) then
  852. CGMessagePos(left.fileinfo,parser_e_illegal_parameter_list)
  853. else if (target_info.system in systems_managed_vm) and
  854. (left.resultdef.typ in [orddef,floatdef]) then
  855. begin
  856. left:=cinlinenode.create(in_box_x,false,ccallparanode.create(left,nil));
  857. typecheckpass(left);
  858. end;
  859. end;
  860. end;
  861. end
  862. else
  863. begin
  864. { check if the argument is allowed }
  865. if (parasym.varspez in [vs_out,vs_var]) then
  866. valid_for_var(left,true);
  867. end;
  868. if parasym.varspez in [vs_var,vs_out,vs_constref] then
  869. set_unique(left);
  870. case parasym.varspez of
  871. vs_out :
  872. begin
  873. { first set written separately to avoid false }
  874. { uninitialized warnings (tbs/tb0542) }
  875. set_varstate(left,vs_written,[]);
  876. set_varstate(left,vs_readwritten,[]);
  877. end;
  878. vs_var,
  879. vs_constref:
  880. set_varstate(left,vs_readwritten,[vsf_must_be_valid,vsf_use_hints]);
  881. else
  882. set_varstate(left,vs_read,[vsf_must_be_valid]);
  883. end;
  884. { must only be done after typeconv PM }
  885. resultdef:=parasym.vardef;
  886. end;
  887. end;
  888. { process next node }
  889. if assigned(right) then
  890. tcallparanode(right).insert_typeconv;
  891. end;
  892. function tcallparanode.can_be_inlined: boolean;
  893. var
  894. n: tnode;
  895. begin
  896. n:=left;
  897. result:=false;
  898. while assigned(n) and
  899. (n.nodetype=typeconvn) do
  900. begin
  901. { look for type conversion nodes which convert a }
  902. { refcounted type into a non-refcounted type }
  903. if not is_managed_type(n.resultdef) and
  904. is_managed_type(ttypeconvnode(n).left.resultdef) then
  905. exit;
  906. n:=ttypeconvnode(n).left;
  907. end;
  908. { also check for dereferencing constant pointers, like }
  909. { tsomerecord(nil^) passed to a const r: tsomerecord }
  910. { parameter }
  911. if (n.nodetype=derefn) then
  912. begin
  913. repeat
  914. n:=tunarynode(n).left;
  915. until (n.nodetype<>typeconvn);
  916. if (n.nodetype in [niln,pointerconstn]) then
  917. exit
  918. end;
  919. result:=true;
  920. end;
  921. function check_contains_stack_tainting_call(var n: tnode; arg: pointer): foreachnoderesult;
  922. begin
  923. if (n.nodetype=calln) and
  924. tcallnode(n).procdefinition.stack_tainting_parameter(callerside) then
  925. result:=fen_norecurse_true
  926. else
  927. result:=fen_false;
  928. end;
  929. function tcallparanode.contains_stack_tainting_call: boolean;
  930. begin
  931. result:=foreachnodestatic(pm_postprocess,left,@check_contains_stack_tainting_call,nil);
  932. end;
  933. procedure tcallparanode.init_contains_stack_tainting_call_cache;
  934. begin
  935. fcontains_stack_tainting_call_cached:=contains_stack_tainting_call;
  936. end;
  937. function tcallparanode.docompare(p: tnode): boolean;
  938. begin
  939. docompare :=
  940. inherited docompare(p) and
  941. fparainit.isequal(tcallparanode(p).fparainit) and
  942. fparacopyback.isequal(tcallparanode(p).fparacopyback) and
  943. (callparaflags = tcallparanode(p).callparaflags)
  944. ;
  945. end;
  946. procedure tcallparanode.printnodetree(var t:text);
  947. begin
  948. printnodelist(t);
  949. end;
  950. {****************************************************************************
  951. TCALLNODE
  952. ****************************************************************************}
  953. constructor tcallnode.create(l:tnode;v : tprocsym;st : TSymtable; mp: tnode; callflags:tcallnodeflags);
  954. begin
  955. inherited create(calln,l,nil);
  956. symtableprocentry:=v;
  957. symtableproc:=st;
  958. callnodeflags:=callflags+[cnf_return_value_used];
  959. methodpointer:=mp;
  960. callinitblock:=nil;
  961. callcleanupblock:=nil;
  962. procdefinition:=nil;
  963. funcretnode:=nil;
  964. paralength:=-1;
  965. varargsparas:=nil;
  966. end;
  967. constructor tcallnode.create_procvar(l,r:tnode);
  968. begin
  969. inherited create(calln,l,r);
  970. symtableprocentry:=nil;
  971. symtableproc:=nil;
  972. methodpointer:=nil;
  973. callinitblock:=nil;
  974. callcleanupblock:=nil;
  975. procdefinition:=nil;
  976. callnodeflags:=[cnf_return_value_used];
  977. funcretnode:=nil;
  978. paralength:=-1;
  979. varargsparas:=nil;
  980. end;
  981. constructor tcallnode.createintern(const name: string; params: tnode);
  982. var
  983. srsym: tsym;
  984. begin
  985. srsym := tsym(systemunit.Find(name));
  986. if not assigned(srsym) and
  987. (cs_compilesystem in current_settings.moduleswitches) then
  988. srsym := tsym(systemunit.Find(upper(name)));
  989. if not assigned(srsym) or
  990. (srsym.typ<>procsym) then
  991. Message1(cg_f_unknown_compilerproc,name);
  992. create(params,tprocsym(srsym),srsym.owner,nil,[]);
  993. end;
  994. constructor tcallnode.createinternfromunit(const fromunit, procname: string; params: tnode);
  995. var
  996. srsym: tsym;
  997. srsymtable: tsymtable;
  998. begin
  999. srsym:=nil;
  1000. if not searchsym_in_named_module(fromunit,procname,srsym,srsymtable) or
  1001. (srsym.typ<>procsym) then
  1002. Message1(cg_f_unknown_compilerproc,fromunit+'.'+procname);
  1003. create(params,tprocsym(srsym),srsymtable,nil,[]);
  1004. end;
  1005. constructor tcallnode.createinternres(const name: string; params: tnode; res:tdef);
  1006. var
  1007. pd : tprocdef;
  1008. begin
  1009. createintern(name,params);
  1010. typedef:=res;
  1011. include(callnodeflags,cnf_typedefset);
  1012. pd:=tprocdef(symtableprocentry.ProcdefList[0]);
  1013. { both the normal and specified resultdef either have to be returned via a }
  1014. { parameter or not, but no mixing (JM) }
  1015. if paramanager.ret_in_param(typedef,pd) xor
  1016. paramanager.ret_in_param(pd.returndef,pd) then
  1017. internalerror(2001082911);
  1018. end;
  1019. constructor tcallnode.createinternresfromunit(const fromunit, procname: string; params: tnode; res:tdef);
  1020. var
  1021. pd : tprocdef;
  1022. begin
  1023. createinternfromunit(fromunit,procname,params);
  1024. typedef:=res;
  1025. include(callnodeflags,cnf_typedefset);
  1026. pd:=tprocdef(symtableprocentry.ProcdefList[0]);
  1027. { both the normal and specified resultdef either have to be returned via a }
  1028. { parameter or not, but no mixing (JM) }
  1029. if paramanager.ret_in_param(typedef,pd) xor
  1030. paramanager.ret_in_param(pd.returndef,pd) then
  1031. internalerror(200108291);
  1032. end;
  1033. constructor tcallnode.createinternreturn(const name: string; params: tnode; returnnode : tnode);
  1034. begin
  1035. createintern(name,params);
  1036. funcretnode:=returnnode;
  1037. end;
  1038. constructor tcallnode.createinternmethod(mp: tnode; const name: string; params: tnode);
  1039. var
  1040. ps: tsym;
  1041. recdef: tabstractrecorddef;
  1042. begin
  1043. typecheckpass(mp);
  1044. if mp.resultdef.typ=classrefdef then
  1045. recdef:=tabstractrecorddef(tclassrefdef(mp.resultdef).pointeddef)
  1046. else
  1047. recdef:=tabstractrecorddef(mp.resultdef);
  1048. ps:=search_struct_member(recdef,name);
  1049. if not assigned(ps) or
  1050. (ps.typ<>procsym) then
  1051. internalerror(2011062806);
  1052. create(params,tprocsym(ps),ps.owner,mp,[]);
  1053. end;
  1054. constructor tcallnode.createinternmethodres(mp: tnode; const name: string; params: tnode; res: tdef);
  1055. begin
  1056. createinternmethod(mp,name,params);
  1057. typedef:=res;
  1058. include(callnodeflags,cnf_typedefset)
  1059. end;
  1060. destructor tcallnode.destroy;
  1061. begin
  1062. methodpointer.free;
  1063. callinitblock.free;
  1064. callcleanupblock.free;
  1065. funcretnode.free;
  1066. if assigned(varargsparas) then
  1067. varargsparas.free;
  1068. {$ifndef symansistr}
  1069. stringdispose(fforcedprocname);
  1070. {$endif symansistr}
  1071. inherited destroy;
  1072. end;
  1073. constructor tcallnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  1074. begin
  1075. callinitblock:=tblocknode(ppuloadnode(ppufile));
  1076. methodpointer:=ppuloadnode(ppufile);
  1077. callcleanupblock:=tblocknode(ppuloadnode(ppufile));
  1078. funcretnode:=ppuloadnode(ppufile);
  1079. inherited ppuload(t,ppufile);
  1080. ppufile.getderef(symtableprocentryderef);
  1081. { TODO: FIXME: No withsymtable support}
  1082. symtableproc:=nil;
  1083. ppufile.getderef(procdefinitionderef);
  1084. ppufile.getsmallset(callnodeflags);
  1085. end;
  1086. procedure tcallnode.ppuwrite(ppufile:tcompilerppufile);
  1087. begin
  1088. ppuwritenode(ppufile,callinitblock);
  1089. ppuwritenode(ppufile,methodpointer);
  1090. ppuwritenode(ppufile,callcleanupblock);
  1091. ppuwritenode(ppufile,funcretnode);
  1092. inherited ppuwrite(ppufile);
  1093. ppufile.putderef(symtableprocentryderef);
  1094. ppufile.putderef(procdefinitionderef);
  1095. ppufile.putsmallset(callnodeflags);
  1096. end;
  1097. procedure tcallnode.buildderefimpl;
  1098. begin
  1099. inherited buildderefimpl;
  1100. symtableprocentryderef.build(symtableprocentry);
  1101. procdefinitionderef.build(procdefinition);
  1102. if assigned(methodpointer) then
  1103. methodpointer.buildderefimpl;
  1104. if assigned(callinitblock) then
  1105. callinitblock.buildderefimpl;
  1106. if assigned(callcleanupblock) then
  1107. callcleanupblock.buildderefimpl;
  1108. if assigned(funcretnode) then
  1109. funcretnode.buildderefimpl;
  1110. end;
  1111. procedure tcallnode.derefimpl;
  1112. var
  1113. pt : tcallparanode;
  1114. i : integer;
  1115. begin
  1116. inherited derefimpl;
  1117. symtableprocentry:=tprocsym(symtableprocentryderef.resolve);
  1118. if assigned(symtableprocentry) then
  1119. symtableproc:=symtableprocentry.owner;
  1120. procdefinition:=tabstractprocdef(procdefinitionderef.resolve);
  1121. if assigned(methodpointer) then
  1122. methodpointer.derefimpl;
  1123. if assigned(callinitblock) then
  1124. callinitblock.derefimpl;
  1125. if assigned(callcleanupblock) then
  1126. callcleanupblock.derefimpl;
  1127. if assigned(funcretnode) then
  1128. funcretnode.derefimpl;
  1129. { generic method has no procdefinition }
  1130. if assigned(procdefinition) then
  1131. begin
  1132. { Connect parasyms }
  1133. pt:=tcallparanode(left);
  1134. while assigned(pt) and
  1135. (cpf_varargs_para in pt.callparaflags) do
  1136. pt:=tcallparanode(pt.right);
  1137. for i:=procdefinition.paras.count-1 downto 0 do
  1138. begin
  1139. if not assigned(pt) then
  1140. internalerror(200311077);
  1141. pt.parasym:=tparavarsym(procdefinition.paras[i]);
  1142. pt:=tcallparanode(pt.right);
  1143. end;
  1144. if assigned(pt) then
  1145. internalerror(200311078);
  1146. end;
  1147. end;
  1148. function tcallnode.dogetcopy : tnode;
  1149. var
  1150. n : tcallnode;
  1151. i : integer;
  1152. hp,hpn : tparavarsym;
  1153. oldleft : tnode;
  1154. para: tcallparanode;
  1155. begin
  1156. { Need to use a hack here to prevent the parameters from being copied.
  1157. The parameters must be copied between callinitblock/callcleanupblock because
  1158. they can reference methodpointer }
  1159. oldleft:=left;
  1160. left:=nil;
  1161. n:=tcallnode(inherited dogetcopy);
  1162. left:=oldleft;
  1163. n.symtableprocentry:=symtableprocentry;
  1164. n.symtableproc:=symtableproc;
  1165. n.procdefinition:=procdefinition;
  1166. n.typedef := typedef;
  1167. n.callnodeflags := callnodeflags;
  1168. if assigned(callinitblock) then
  1169. n.callinitblock:=tblocknode(callinitblock.dogetcopy)
  1170. else
  1171. n.callinitblock:=nil;
  1172. { callinitblock is copied, now references to the temp will also be copied
  1173. correctly. We can now copy the parameters, funcret and methodpointer }
  1174. if assigned(left) then
  1175. n.left:=left.dogetcopy
  1176. else
  1177. n.left:=nil;
  1178. if assigned(methodpointer) then
  1179. n.methodpointer:=methodpointer.dogetcopy
  1180. else
  1181. n.methodpointer:=nil;
  1182. { must be copied before the funcretnode, because the callcleanup block
  1183. may contain a ttempdeletenode that sets the tempinfo of the
  1184. corresponding temp to ti_nextref_set_hookoncopy_nil, and this nextref
  1185. itself may be the funcretnode }
  1186. if assigned(callcleanupblock) then
  1187. n.callcleanupblock:=tblocknode(callcleanupblock.dogetcopy)
  1188. else
  1189. n.callcleanupblock:=nil;
  1190. if assigned(funcretnode) then
  1191. n.funcretnode:=funcretnode.dogetcopy
  1192. else
  1193. n.funcretnode:=nil;
  1194. if assigned(varargsparas) then
  1195. begin
  1196. n.varargsparas:=tvarargsparalist.create(true);
  1197. for i:=0 to varargsparas.count-1 do
  1198. begin
  1199. hp:=tparavarsym(varargsparas[i]);
  1200. hpn:=cparavarsym.create(hp.realname,hp.paranr,hp.varspez,hp.vardef,[]);
  1201. n.varargsparas.add(hpn);
  1202. para:=tcallparanode(n.left);
  1203. while assigned(para) do
  1204. begin
  1205. if (para.parasym=hp) then
  1206. para.parasym:=hpn;
  1207. para:=tcallparanode(para.right);
  1208. end;
  1209. end;
  1210. end
  1211. else
  1212. n.varargsparas:=nil;
  1213. {$ifdef symansistr}
  1214. n.fforcedprocname:=fforcedprocname;
  1215. {$else symansistr}
  1216. if assigned(fforcedprocname) then
  1217. n.fforcedprocname:=stringdup(fforcedprocname^)
  1218. else
  1219. n.fforcedprocname:=nil;
  1220. {$endif symansistr}
  1221. result:=n;
  1222. end;
  1223. function tcallnode.docompare(p: tnode): boolean;
  1224. begin
  1225. docompare :=
  1226. inherited docompare(p) and
  1227. (symtableprocentry = tcallnode(p).symtableprocentry) and
  1228. (procdefinition = tcallnode(p).procdefinition) and
  1229. (methodpointer.isequal(tcallnode(p).methodpointer)) and
  1230. (((cnf_typedefset in callnodeflags) and (cnf_typedefset in tcallnode(p).callnodeflags) and
  1231. (equal_defs(typedef,tcallnode(p).typedef))) or
  1232. (not(cnf_typedefset in callnodeflags) and not(cnf_typedefset in tcallnode(p).callnodeflags)));
  1233. end;
  1234. procedure tcallnode.printnodedata(var t:text);
  1235. begin
  1236. if assigned(procdefinition) and
  1237. (procdefinition.typ=procdef) then
  1238. writeln(t,printnodeindention,'proc = ',tprocdef(procdefinition).fullprocname(true))
  1239. else
  1240. begin
  1241. if assigned(symtableprocentry) then
  1242. writeln(t,printnodeindention,'proc = ',symtableprocentry.name)
  1243. else
  1244. writeln(t,printnodeindention,'proc = <nil>');
  1245. end;
  1246. if assigned(methodpointer) then
  1247. begin
  1248. writeln(t,printnodeindention,'methodpointer =');
  1249. printnode(t,methodpointer);
  1250. end;
  1251. if assigned(callinitblock) then
  1252. begin
  1253. writeln(t,printnodeindention,'callinitblock =');
  1254. printnode(t,callinitblock);
  1255. end;
  1256. if assigned(callcleanupblock) then
  1257. begin
  1258. writeln(t,printnodeindention,'callcleanupblock =');
  1259. printnode(t,callcleanupblock);
  1260. end;
  1261. if assigned(right) then
  1262. begin
  1263. writeln(t,printnodeindention,'right =');
  1264. printnode(t,right);
  1265. end;
  1266. if assigned(left) then
  1267. begin
  1268. writeln(t,printnodeindention,'left =');
  1269. printnode(t,left);
  1270. end;
  1271. end;
  1272. procedure tcallnode.insertintolist(l : tnodelist);
  1273. begin
  1274. end;
  1275. procedure tcallnode.add_init_statement(n:tnode);
  1276. var
  1277. lastinitstatement : tstatementnode;
  1278. begin
  1279. if not assigned(callinitblock) then
  1280. callinitblock:=internalstatements(lastinitstatement)
  1281. else
  1282. lastinitstatement:=laststatement(callinitblock);
  1283. { all these nodes must be immediately typechecked, because this routine }
  1284. { can be called from pass_1 (i.e., after typecheck has already run) and }
  1285. { moreover, the entire blocks themselves are also only typechecked in }
  1286. { pass_1, while the the typeinfo is already required after the }
  1287. { typecheck pass for simplify purposes (not yet perfect, because the }
  1288. { statementnodes themselves are not typechecked this way) }
  1289. typecheckpass(n);
  1290. addstatement(lastinitstatement,n);
  1291. end;
  1292. procedure tcallnode.add_done_statement(n:tnode);
  1293. var
  1294. lastdonestatement : tstatementnode;
  1295. begin
  1296. if not assigned(callcleanupblock) then
  1297. callcleanupblock:=internalstatements(lastdonestatement)
  1298. else
  1299. lastdonestatement:=laststatement(callcleanupblock);
  1300. { see comments in add_init_statement }
  1301. typecheckpass(n);
  1302. addstatement(lastdonestatement,n);
  1303. end;
  1304. function tcallnode.para_count:longint;
  1305. var
  1306. ppn : tcallparanode;
  1307. begin
  1308. result:=0;
  1309. ppn:=tcallparanode(left);
  1310. while assigned(ppn) do
  1311. begin
  1312. if not(assigned(ppn.parasym) and
  1313. (vo_is_hidden_para in ppn.parasym.varoptions)) then
  1314. inc(result);
  1315. ppn:=tcallparanode(ppn.right);
  1316. end;
  1317. end;
  1318. function tcallnode.required_para_count: longint;
  1319. var
  1320. ppn : tcallparanode;
  1321. begin
  1322. result:=0;
  1323. ppn:=tcallparanode(left);
  1324. while assigned(ppn) do
  1325. begin
  1326. if not(assigned(ppn.parasym) and
  1327. ((vo_is_hidden_para in ppn.parasym.varoptions) or
  1328. assigned(ppn.parasym.defaultconstsym))) then
  1329. inc(result);
  1330. ppn:=tcallparanode(ppn.right);
  1331. end;
  1332. end;
  1333. function tcallnode.is_simple_para_load(p:tnode; may_be_in_reg: boolean):boolean;
  1334. var
  1335. hp : tnode;
  1336. begin
  1337. hp:=p;
  1338. while assigned(hp) and
  1339. (hp.nodetype=typeconvn) and
  1340. (ttypeconvnode(hp).convtype=tc_equal) do
  1341. hp:=tunarynode(hp).left;
  1342. result:=(hp.nodetype in [typen,loadvmtaddrn,loadn,temprefn,arrayconstructorn,addrn]);
  1343. if result and
  1344. not(may_be_in_reg) then
  1345. case hp.nodetype of
  1346. loadn:
  1347. result:=(tabstractvarsym(tloadnode(hp).symtableentry).varregable in [vr_none,vr_addr]);
  1348. temprefn:
  1349. result:=not(ti_may_be_in_reg in ttemprefnode(hp).tempinfo^.flags);
  1350. end;
  1351. end;
  1352. function look_for_call(var n: tnode; arg: pointer): foreachnoderesult;
  1353. begin
  1354. case n.nodetype of
  1355. calln,asn:
  1356. result := fen_norecurse_true;
  1357. typen,loadvmtaddrn,loadn,temprefn,arrayconstructorn:
  1358. result := fen_norecurse_false;
  1359. else
  1360. result := fen_false;
  1361. end;
  1362. end;
  1363. procedure tcallnode.maybe_load_in_temp(var p:tnode);
  1364. var
  1365. loadp,
  1366. refp : tnode;
  1367. hdef : tdef;
  1368. ptemp : ttempcreatenode;
  1369. usederef : boolean;
  1370. begin
  1371. { Load all complex loads into a temp to prevent
  1372. double calls to a function. We can't simply check for a hp.nodetype=calln }
  1373. if assigned(p) and
  1374. foreachnodestatic(p,@look_for_call,nil) then
  1375. begin
  1376. { temp create }
  1377. usederef:=(p.resultdef.typ in [arraydef,recorddef]) or
  1378. is_shortstring(p.resultdef) or
  1379. is_object(p.resultdef);
  1380. if usederef then
  1381. hdef:=getpointerdef(p.resultdef)
  1382. else
  1383. hdef:=p.resultdef;
  1384. ptemp:=ctempcreatenode.create(hdef,hdef.size,tt_persistent,true);
  1385. if usederef then
  1386. begin
  1387. loadp:=caddrnode.create_internal(p);
  1388. refp:=cderefnode.create(ctemprefnode.create(ptemp));
  1389. end
  1390. else
  1391. begin
  1392. loadp:=p;
  1393. refp:=ctemprefnode.create(ptemp)
  1394. end;
  1395. add_init_statement(ptemp);
  1396. add_init_statement(cassignmentnode.create(
  1397. ctemprefnode.create(ptemp),
  1398. loadp));
  1399. add_done_statement(ctempdeletenode.create(ptemp));
  1400. { new tree is only a temp reference }
  1401. p:=refp;
  1402. typecheckpass(p);
  1403. end;
  1404. end;
  1405. function tcallnode.gen_high_tree(var p:tnode;paradef:tdef):tnode;
  1406. { When passing an array to an open array, or a string to an open string,
  1407. some code is needed that generates the high bound of the array. This
  1408. function returns a tree containing the nodes for it. }
  1409. var
  1410. temp: tnode;
  1411. len : integer;
  1412. loadconst : boolean;
  1413. hightree,l,r : tnode;
  1414. defkind: tdeftyp;
  1415. begin
  1416. len:=-1;
  1417. loadconst:=true;
  1418. hightree:=nil;
  1419. { constant strings are internally stored as array of char, but if the
  1420. parameter is a string also treat it like one }
  1421. defkind:=p.resultdef.typ;
  1422. if (p.nodetype=stringconstn) and
  1423. (paradef.typ=stringdef) then
  1424. defkind:=stringdef;
  1425. case defkind of
  1426. arraydef :
  1427. begin
  1428. if (paradef.typ<>arraydef) then
  1429. internalerror(200405241);
  1430. { passing a string to an array of char }
  1431. if (p.nodetype=stringconstn) and
  1432. is_char(tarraydef(paradef).elementdef) then
  1433. begin
  1434. len:=tstringconstnode(p).len;
  1435. if len>0 then
  1436. dec(len);
  1437. end
  1438. else
  1439. { handle special case of passing an single array to an array of array }
  1440. if compare_defs(tarraydef(paradef).elementdef,p.resultdef,nothingn)>=te_equal then
  1441. len:=0
  1442. else
  1443. begin
  1444. { handle via a normal inline in_high_x node }
  1445. loadconst:=false;
  1446. { slice? }
  1447. if (p.nodetype=inlinen) and (tinlinenode(p).inlinenumber=in_slice_x) then
  1448. with Tcallparanode(Tinlinenode(p).left) do
  1449. begin
  1450. {Array slice using slice builtin function.}
  1451. l:=Tcallparanode(right).left;
  1452. hightree:=caddnode.create(subn,l,genintconstnode(1));
  1453. Tcallparanode(right).left:=nil;
  1454. {Remove the inline node.}
  1455. temp:=p;
  1456. p:=left;
  1457. Tcallparanode(tinlinenode(temp).left).left:=nil;
  1458. temp.free;
  1459. typecheckpass(hightree);
  1460. end
  1461. else if (p.nodetype=vecn) and (Tvecnode(p).right.nodetype=rangen) then
  1462. begin
  1463. {Array slice using .. operator.}
  1464. with Trangenode(Tvecnode(p).right) do
  1465. begin
  1466. l:=left; {Get lower bound.}
  1467. r:=right; {Get upper bound.}
  1468. end;
  1469. {In the procedure the array range is 0..(upper_bound-lower_bound).}
  1470. hightree:=caddnode.create(subn,r,l);
  1471. {Replace the rangnode in the tree by its lower_bound, and
  1472. dispose the rangenode.}
  1473. temp:=Tvecnode(p).right;
  1474. Tvecnode(p).right:=l.getcopy;
  1475. {Typecheckpass can only be performed *after* the l.getcopy since it
  1476. can modify the tree, and l is in the hightree.}
  1477. typecheckpass(hightree);
  1478. with Trangenode(temp) do
  1479. begin
  1480. left:=nil;
  1481. right:=nil;
  1482. end;
  1483. temp.free;
  1484. {Tree changed from p[l..h] to p[l], recalculate resultdef.}
  1485. p.resultdef:=nil;
  1486. typecheckpass(p);
  1487. end
  1488. else
  1489. begin
  1490. maybe_load_in_temp(p);
  1491. hightree:=geninlinenode(in_high_x,false,p.getcopy);
  1492. typecheckpass(hightree);
  1493. { only substract low(array) if it's <> 0 }
  1494. temp:=geninlinenode(in_low_x,false,p.getcopy);
  1495. typecheckpass(temp);
  1496. if (temp.nodetype <> ordconstn) or
  1497. (tordconstnode(temp).value <> 0) then
  1498. hightree := caddnode.create(subn,hightree,temp)
  1499. else
  1500. temp.free;
  1501. end;
  1502. end;
  1503. end;
  1504. stringdef :
  1505. begin
  1506. if is_open_string(paradef) then
  1507. begin
  1508. { a stringconstn is not a simple parameter and hence would be
  1509. loaded in a temp, but in that case the high() node
  1510. a) goes wrong (it cannot deal with a temp node)
  1511. b) would give a generic result instead of one specific to
  1512. this constant string
  1513. }
  1514. if p.nodetype<>stringconstn then
  1515. maybe_load_in_temp(p);
  1516. { handle via a normal inline in_high_x node }
  1517. loadconst := false;
  1518. hightree := geninlinenode(in_high_x,false,p.getcopy);
  1519. end
  1520. else
  1521. { handle special case of passing an single string to an array of string }
  1522. if compare_defs(tarraydef(paradef).elementdef,p.resultdef,nothingn)>=te_equal then
  1523. len:=0
  1524. else
  1525. { passing a string to an array of char }
  1526. if (p.nodetype=stringconstn) and
  1527. is_char(tarraydef(paradef).elementdef) then
  1528. begin
  1529. len:=tstringconstnode(p).len;
  1530. if len>0 then
  1531. dec(len);
  1532. end
  1533. else
  1534. begin
  1535. maybe_load_in_temp(p);
  1536. hightree:=caddnode.create(subn,geninlinenode(in_length_x,false,p.getcopy),
  1537. cordconstnode.create(1,sinttype,false));
  1538. loadconst:=false;
  1539. end;
  1540. end;
  1541. else
  1542. len:=0;
  1543. end;
  1544. if loadconst then
  1545. hightree:=cordconstnode.create(len,sinttype,true)
  1546. else
  1547. begin
  1548. if not assigned(hightree) then
  1549. internalerror(200304071);
  1550. { Need to use explicit, because it can also be a enum }
  1551. hightree:=ctypeconvnode.create_internal(hightree,sinttype);
  1552. end;
  1553. result:=hightree;
  1554. end;
  1555. function tcallnode.gen_procvar_context_tree_self:tnode;
  1556. begin
  1557. { Load tmehodpointer(right).self }
  1558. result:=genloadfield(ctypeconvnode.create_internal(
  1559. right.getcopy,methodpointertype),
  1560. 'self');
  1561. end;
  1562. function tcallnode.gen_procvar_context_tree_parentfp: tnode;
  1563. begin
  1564. { Load tnestedprocpointer(right).parentfp }
  1565. result:=genloadfield(ctypeconvnode.create_internal(
  1566. right.getcopy,nestedprocpointertype),
  1567. 'parentfp');
  1568. end;
  1569. function tcallnode.gen_self_tree:tnode;
  1570. var
  1571. selftree : tnode;
  1572. selfdef : tdef;
  1573. temp : ttempcreatenode;
  1574. begin
  1575. selftree:=nil;
  1576. { When methodpointer was a callnode we must load it first into a
  1577. temp to prevent processing the callnode twice }
  1578. if (methodpointer.nodetype=calln) then
  1579. internalerror(200405121);
  1580. { Objective-C: objc_convert_to_message_send() already did all necessary
  1581. transformation on the methodpointer }
  1582. if (procdefinition.typ=procdef) and
  1583. (po_objc in tprocdef(procdefinition).procoptions) then
  1584. selftree:=methodpointer.getcopy
  1585. { inherited }
  1586. else if (cnf_inherited in callnodeflags) then
  1587. begin
  1588. selftree:=load_self_node;
  1589. { we can call an inherited class static/method from a regular method
  1590. -> self node must change from instance pointer to vmt pointer)
  1591. }
  1592. if (procdefinition.procoptions*[po_classmethod,po_staticmethod] <> []) and
  1593. (selftree.resultdef.typ<>classrefdef) then
  1594. selftree:=cloadvmtaddrnode.create(selftree);
  1595. end
  1596. else
  1597. { constructors }
  1598. if (procdefinition.proctypeoption=potype_constructor) then
  1599. begin
  1600. if (methodpointer.resultdef.typ=classrefdef) or
  1601. (cnf_new_call in callnodeflags) then
  1602. if not is_javaclass(tdef(procdefinition.owner.defowner)) then
  1603. begin
  1604. if (cnf_new_call in callnodeflags) then
  1605. { old-style object: push 0 as self }
  1606. selftree:=cpointerconstnode.create(0,voidpointertype)
  1607. else
  1608. begin
  1609. { class-style: push classtype }
  1610. selftree:=methodpointer.getcopy;
  1611. if selftree.nodetype=typen then
  1612. begin
  1613. selftree:=cloadvmtaddrnode.create(selftree);
  1614. tloadvmtaddrnode(selftree).forcall:=true;
  1615. end;
  1616. end;
  1617. end
  1618. else
  1619. { special handling for Java constructors, handled in
  1620. tjvmcallnode.extra_pre_call_code }
  1621. selftree:=cnothingnode.create
  1622. else
  1623. begin
  1624. if methodpointer.nodetype=typen then
  1625. if (methodpointer.resultdef.typ<>objectdef) then
  1626. begin
  1627. if not(target_info.system in systems_jvm) then
  1628. begin
  1629. { TSomeRecord.Constructor call. We need to allocate }
  1630. { self node as a temp node of the result type }
  1631. temp:=ctempcreatenode.create(methodpointer.resultdef,methodpointer.resultdef.size,tt_persistent,false);
  1632. add_init_statement(temp);
  1633. add_done_statement(ctempdeletenode.create_normal_temp(temp));
  1634. selftree:=ctemprefnode.create(temp);
  1635. end
  1636. else
  1637. begin
  1638. { special handling for Java constructors, handled in
  1639. tjvmcallnode.extra_pre_call_code }
  1640. selftree:=cnothingnode.create
  1641. end;
  1642. end
  1643. else
  1644. selftree:=load_self_node
  1645. else
  1646. selftree:=methodpointer.getcopy;
  1647. end;
  1648. end
  1649. else
  1650. { Calling a static/class method }
  1651. if (po_classmethod in procdefinition.procoptions) or
  1652. (po_staticmethod in procdefinition.procoptions) then
  1653. begin
  1654. if (procdefinition.typ<>procdef) then
  1655. internalerror(200305062);
  1656. { if the method belongs to a helper then we need to use the
  1657. extended type for references to Self }
  1658. if is_objectpascal_helper(tprocdef(procdefinition).struct) then
  1659. selfdef:=tobjectdef(tprocdef(procdefinition).struct).extendeddef
  1660. else
  1661. selfdef:=tprocdef(procdefinition).struct;
  1662. if ((selfdef.typ in [recorddef,objectdef]) and
  1663. (oo_has_vmt in tabstractrecorddef(selfdef).objectoptions)) or
  1664. { all Java classes have a "VMT" }
  1665. (target_info.system in systems_jvm) then
  1666. begin
  1667. { we only need the vmt, loading self is not required and there is no
  1668. need to check for typen, because that will always get the
  1669. loadvmtaddrnode added }
  1670. selftree:=methodpointer.getcopy;
  1671. if (methodpointer.resultdef.typ<>classrefdef) or
  1672. (methodpointer.nodetype = typen) then
  1673. selftree:=cloadvmtaddrnode.create(selftree);
  1674. end
  1675. else
  1676. selftree:=cpointerconstnode.create(0,voidpointertype);
  1677. end
  1678. else
  1679. begin
  1680. if methodpointer.nodetype=typen then
  1681. selftree:=load_self_node
  1682. else
  1683. selftree:=methodpointer.getcopy;
  1684. end;
  1685. result:=selftree;
  1686. end;
  1687. procedure tcallnode.register_created_object_types;
  1688. function checklive(def: tdef): boolean;
  1689. begin
  1690. if assigned(current_procinfo) and
  1691. not(po_inline in current_procinfo.procdef.procoptions) and
  1692. not wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname) then
  1693. begin
  1694. {$ifdef debug_deadcode}
  1695. writeln(' NOT adding creadion of ',def.typename,' because performed in dead stripped proc: ',current_procinfo.procdef.typename);
  1696. {$endif debug_deadcode}
  1697. result:=false;
  1698. end
  1699. else
  1700. result:=true;
  1701. end;
  1702. var
  1703. crefdef,
  1704. systobjectdef : tdef;
  1705. begin
  1706. { only makes sense for methods }
  1707. if not assigned(methodpointer) then
  1708. exit;
  1709. if (methodpointer.resultdef.typ=classrefdef) then
  1710. begin
  1711. { constructor call via classreference => allocate memory }
  1712. if (procdefinition.proctypeoption=potype_constructor) then
  1713. begin
  1714. { Only a typenode can be passed when it is called with <class of xx>.create }
  1715. if (methodpointer.nodetype=typen) then
  1716. begin
  1717. if checklive(methodpointer.resultdef) then
  1718. { we know the exact class type being created }
  1719. tclassrefdef(methodpointer.resultdef).pointeddef.register_created_object_type
  1720. end
  1721. else
  1722. begin
  1723. { the loadvmtaddrnode is already created in case of classtype.create }
  1724. if (methodpointer.nodetype=loadvmtaddrn) and
  1725. (tloadvmtaddrnode(methodpointer).left.nodetype=typen) then
  1726. begin
  1727. if checklive(methodpointer.resultdef) then
  1728. tclassrefdef(methodpointer.resultdef).pointeddef.register_created_object_type
  1729. end
  1730. else
  1731. begin
  1732. if checklive(methodpointer.resultdef) then
  1733. begin
  1734. { special case: if the classref comes from x.classtype (with classtype,
  1735. being tobject.classtype) then the created instance is x or a descendant
  1736. of x (rather than tobject or a descendant of tobject)
  1737. }
  1738. systobjectdef:=search_system_type('TOBJECT').typedef;
  1739. if (methodpointer.nodetype=calln) and
  1740. { not a procvar call }
  1741. not assigned(right) and
  1742. { procdef is owned by system.tobject }
  1743. (tprocdef(tcallnode(methodpointer).procdefinition).owner.defowner=systobjectdef) and
  1744. { we're calling system.tobject.classtype }
  1745. (tcallnode(methodpointer).symtableprocentry.name='CLASSTYPE') and
  1746. { could again be a classrefdef, but unlikely }
  1747. (tcallnode(methodpointer).methodpointer.resultdef.typ=objectdef) and
  1748. { don't go through this trouble if it was already a tobject }
  1749. (tcallnode(methodpointer).methodpointer.resultdef<>systobjectdef) then
  1750. begin
  1751. { register this object type as classref, so all descendents will also
  1752. be marked as instantiatable (only the pointeddef will actually be
  1753. recorded, so it's no problem that the clasrefdef is only temporary)
  1754. }
  1755. crefdef:=cclassrefdef.create(tcallnode(methodpointer).methodpointer.resultdef);
  1756. { and register it }
  1757. crefdef.register_created_object_type;
  1758. end
  1759. else
  1760. { the created class can be any child class as well -> register classrefdef }
  1761. methodpointer.resultdef.register_created_object_type;
  1762. end;
  1763. end;
  1764. end;
  1765. end
  1766. end
  1767. else
  1768. { Old style object }
  1769. if is_object(methodpointer.resultdef) then
  1770. begin
  1771. { constructor with extended syntax called from new }
  1772. if (cnf_new_call in callnodeflags) then
  1773. begin
  1774. if checklive(methodpointer.resultdef) then
  1775. methodpointer.resultdef.register_created_object_type;
  1776. end
  1777. else
  1778. { normal object call like obj.proc }
  1779. if not(cnf_dispose_call in callnodeflags) and
  1780. not(cnf_inherited in callnodeflags) and
  1781. not(cnf_member_call in callnodeflags) then
  1782. begin
  1783. if (procdefinition.proctypeoption=potype_constructor) then
  1784. begin
  1785. if (methodpointer.nodetype<>typen) and
  1786. checklive(methodpointer.resultdef) then
  1787. methodpointer.resultdef.register_created_object_type;
  1788. end
  1789. end;
  1790. end;
  1791. end;
  1792. function tcallnode.get_expect_loc: tcgloc;
  1793. var
  1794. realresdef: tstoreddef;
  1795. begin
  1796. if not assigned(typedef) then
  1797. realresdef:=tstoreddef(resultdef)
  1798. else
  1799. realresdef:=tstoreddef(typedef);
  1800. if realresdef.is_intregable then
  1801. result:=LOC_REGISTER
  1802. else if (realresdef.typ=floatdef) and
  1803. not(cs_fp_emulation in current_settings.moduleswitches) then
  1804. if use_vectorfpu(realresdef) then
  1805. result:=LOC_MMREGISTER
  1806. else
  1807. result:=LOC_FPUREGISTER
  1808. else
  1809. result:=LOC_REFERENCE
  1810. end;
  1811. procedure tcallnode.gen_syscall_para(para: tcallparanode);
  1812. begin
  1813. { unsupported }
  1814. internalerror(2014040101);
  1815. end;
  1816. procedure tcallnode.objc_convert_to_message_send;
  1817. var
  1818. block,
  1819. selftree : tnode;
  1820. statements : tstatementnode;
  1821. field : tfieldvarsym;
  1822. temp : ttempcreatenode;
  1823. selfrestype,
  1824. objcsupertype : tdef;
  1825. srsym : tsym;
  1826. srsymtable : tsymtable;
  1827. msgsendname : string;
  1828. begin
  1829. if not(m_objectivec1 in current_settings.modeswitches) then
  1830. Message(parser_f_modeswitch_objc_required);
  1831. { typecheck pass must already have run on the call node,
  1832. because pass1 calls this method
  1833. }
  1834. { default behaviour: call objc_msgSend and friends;
  1835. 64 bit targets for Mac OS X can override this as they
  1836. can call messages via an indirect function call similar to
  1837. dynamically linked functions, ARM maybe as well (not checked)
  1838. Which variant of objc_msgSend is used depends on the
  1839. result type, and on whether or not it's an inherited call.
  1840. }
  1841. { make sure we don't perform this transformation twice in case
  1842. firstpass would be called multiple times }
  1843. include(callnodeflags,cnf_objc_processed);
  1844. { make sure the methodpointer doesn't get translated into a call
  1845. as well (endless loop) }
  1846. if methodpointer.nodetype=loadvmtaddrn then
  1847. tloadvmtaddrnode(methodpointer).forcall:=true;
  1848. { A) set the appropriate objc_msgSend* variant to call }
  1849. { record returned via implicit pointer }
  1850. if paramanager.ret_in_param(resultdef,procdefinition) then
  1851. begin
  1852. if not(cnf_inherited in callnodeflags) then
  1853. msgsendname:='OBJC_MSGSEND_STRET'
  1854. {$if defined(onlymacosx10_6) or defined(arm) }
  1855. else if (target_info.system in systems_objc_nfabi) then
  1856. msgsendname:='OBJC_MSGSENDSUPER2_STRET'
  1857. {$endif onlymacosx10_6 or arm}
  1858. else
  1859. msgsendname:='OBJC_MSGSENDSUPER_STRET'
  1860. end
  1861. {$ifdef i386}
  1862. { special case for fpu results on i386 for non-inherited calls }
  1863. { TODO: also for x86_64 "extended" results }
  1864. else if (resultdef.typ=floatdef) and
  1865. not(cnf_inherited in callnodeflags) then
  1866. msgsendname:='OBJC_MSGSEND_FPRET'
  1867. {$endif}
  1868. { default }
  1869. else if not(cnf_inherited in callnodeflags) then
  1870. msgsendname:='OBJC_MSGSEND'
  1871. {$if defined(onlymacosx10_6) or defined(arm) }
  1872. else if (target_info.system in systems_objc_nfabi) then
  1873. msgsendname:='OBJC_MSGSENDSUPER2'
  1874. {$endif onlymacosx10_6 or arm}
  1875. else
  1876. msgsendname:='OBJC_MSGSENDSUPER';
  1877. { get the mangled name }
  1878. srsym:=nil;
  1879. if not searchsym_in_named_module('OBJC',msgsendname,srsym,srsymtable) or
  1880. (srsym.typ<>procsym) or
  1881. (tprocsym(srsym).ProcdefList.count<>1) then
  1882. Message1(cg_f_unknown_compilerproc,'objc.'+msgsendname);
  1883. {$ifdef symansistr}
  1884. fforcedprocname:=tprocdef(tprocsym(srsym).ProcdefList[0]).mangledname;
  1885. {$else symansistr}
  1886. fforcedprocname:=stringdup(tprocdef(tprocsym(srsym).ProcdefList[0]).mangledname);
  1887. {$endif symansistr}
  1888. { B) Handle self }
  1889. { 1) in case of sending a message to a superclass, self is a pointer to
  1890. an objc_super record
  1891. }
  1892. if (cnf_inherited in callnodeflags) then
  1893. begin
  1894. block:=internalstatements(statements);
  1895. objcsupertype:=search_named_unit_globaltype('OBJC','OBJC_SUPER',true).typedef;
  1896. if (objcsupertype.typ<>recorddef) then
  1897. internalerror(2009032901);
  1898. { temp for the for the objc_super record }
  1899. temp:=ctempcreatenode.create(objcsupertype,objcsupertype.size,tt_persistent,false);
  1900. addstatement(statements,temp);
  1901. { initialize objc_super record }
  1902. selftree:=load_self_node;
  1903. { we can call an inherited class static/method from a regular method
  1904. -> self node must change from instance pointer to vmt pointer)
  1905. }
  1906. if (po_classmethod in procdefinition.procoptions) and
  1907. (selftree.resultdef.typ<>classrefdef) then
  1908. begin
  1909. selftree:=cloadvmtaddrnode.create(selftree);
  1910. { since we're in a class method of the current class, its
  1911. information has already been initialized (and that of all of
  1912. its parent classes too) }
  1913. tloadvmtaddrnode(selftree).forcall:=true;
  1914. typecheckpass(selftree);
  1915. end;
  1916. selfrestype:=selftree.resultdef;
  1917. field:=tfieldvarsym(trecorddef(objcsupertype).symtable.find('RECEIVER'));
  1918. if not assigned(field) then
  1919. internalerror(2009032902);
  1920. { first the destination object/class instance }
  1921. addstatement(statements,
  1922. cassignmentnode.create(
  1923. csubscriptnode.create(field,ctemprefnode.create(temp)),
  1924. selftree
  1925. )
  1926. );
  1927. { and secondly, the class type in which the selector must be looked
  1928. up (the parent class in case of an instance method, the parent's
  1929. metaclass in case of a class method) }
  1930. field:=tfieldvarsym(trecorddef(objcsupertype).symtable.find('_CLASS'));
  1931. if not assigned(field) then
  1932. internalerror(2009032903);
  1933. addstatement(statements,
  1934. cassignmentnode.create(
  1935. csubscriptnode.create(field,ctemprefnode.create(temp)),
  1936. objcsuperclassnode(selftree.resultdef)
  1937. )
  1938. );
  1939. { result of this block is the address of this temp }
  1940. addstatement(statements,ctypeconvnode.create_internal(
  1941. caddrnode.create_internal(ctemprefnode.create(temp)),selfrestype)
  1942. );
  1943. { replace the method pointer with the address of this temp }
  1944. methodpointer.free;
  1945. methodpointer:=block;
  1946. typecheckpass(block);
  1947. end
  1948. else
  1949. { 2) regular call (not inherited) }
  1950. begin
  1951. { a) If we're calling a class method, use a class ref. }
  1952. if (po_classmethod in procdefinition.procoptions) and
  1953. ((methodpointer.nodetype=typen) or
  1954. (methodpointer.resultdef.typ<>classrefdef)) then
  1955. begin
  1956. methodpointer:=cloadvmtaddrnode.create(methodpointer);
  1957. { no need to obtain the class ref by calling class(), sending
  1958. this message will initialize it if necessary }
  1959. tloadvmtaddrnode(methodpointer).forcall:=true;
  1960. firstpass(methodpointer);
  1961. end;
  1962. end;
  1963. end;
  1964. function tcallnode.gen_vmt_tree:tnode;
  1965. var
  1966. vmttree : tnode;
  1967. begin
  1968. vmttree:=nil;
  1969. if not(procdefinition.proctypeoption in [potype_constructor,potype_destructor]) then
  1970. internalerror(200305051);
  1971. { When methodpointer was a callnode we must load it first into a
  1972. temp to prevent the processing callnode twice }
  1973. if (methodpointer.nodetype=calln) then
  1974. internalerror(200405122);
  1975. { Handle classes and legacy objects separate to make it
  1976. more maintainable }
  1977. if (methodpointer.resultdef.typ=classrefdef) then
  1978. begin
  1979. if not is_class(tclassrefdef(methodpointer.resultdef).pointeddef) then
  1980. internalerror(200501041);
  1981. { constructor call via classreference => allocate memory }
  1982. if (procdefinition.proctypeoption=potype_constructor) then
  1983. begin
  1984. vmttree:=cpointerconstnode.create(1,voidpointertype);
  1985. end
  1986. else { <class of xx>.destroy is not valid }
  1987. InternalError(2014020601);
  1988. end
  1989. else
  1990. { Class style objects }
  1991. if is_class(methodpointer.resultdef) then
  1992. begin
  1993. { inherited call, no create/destroy }
  1994. if (cnf_inherited in callnodeflags) then
  1995. vmttree:=cpointerconstnode.create(0,voidpointertype)
  1996. else
  1997. { do not create/destroy when called from member function
  1998. without specifying self explicit }
  1999. if (cnf_member_call in callnodeflags) then
  2000. begin
  2001. { destructor (in the same class, since cnf_member_call):
  2002. if not called from a destructor then
  2003. call beforedestruction and release instance, vmt=1
  2004. else
  2005. don't release instance, vmt=0
  2006. constructor (in the same class, since cnf_member_call):
  2007. if called from a constructor then
  2008. don't call afterconstruction, vmt=0
  2009. else
  2010. call afterconstrution but not NewInstance, vmt=-1 }
  2011. if (procdefinition.proctypeoption=potype_destructor) then
  2012. if (current_procinfo.procdef.proctypeoption<>potype_constructor) then
  2013. vmttree:=cpointerconstnode.create(1,voidpointertype)
  2014. else
  2015. vmttree:=cpointerconstnode.create(0,voidpointertype)
  2016. else if (current_procinfo.procdef.proctypeoption=potype_constructor) and
  2017. (procdefinition.proctypeoption=potype_constructor) then
  2018. vmttree:=cpointerconstnode.create(0,voidpointertype)
  2019. else
  2020. vmttree:=cpointerconstnode.create(TConstPtrUInt(-1),voidpointertype);
  2021. end
  2022. else
  2023. { normal call to method like cl1.proc }
  2024. begin
  2025. { destructor:
  2026. if not called from exception block in constructor
  2027. call beforedestruction and release instance, vmt=1
  2028. else
  2029. don't call beforedestruction and release instance, vmt=-1
  2030. constructor:
  2031. if called from a constructor in the same class using self.create then
  2032. don't call afterconstruction, vmt=0
  2033. else
  2034. call afterconstruction, vmt=1 }
  2035. if (procdefinition.proctypeoption=potype_destructor) then
  2036. if not(cnf_create_failed in callnodeflags) then
  2037. vmttree:=cpointerconstnode.create(1,voidpointertype)
  2038. else
  2039. vmttree:=cpointerconstnode.create(TConstPtrUInt(-1),voidpointertype)
  2040. else
  2041. begin
  2042. if (current_procinfo.procdef.proctypeoption=potype_constructor) and
  2043. (procdefinition.proctypeoption=potype_constructor) and
  2044. (methodpointer.nodetype=loadn) and
  2045. (loadnf_is_self in tloadnode(methodpointer).loadnodeflags) then
  2046. vmttree:=cpointerconstnode.create(0,voidpointertype)
  2047. else
  2048. vmttree:=cpointerconstnode.create(TConstPtrUInt(-1),voidpointertype);
  2049. end;
  2050. end;
  2051. end
  2052. else
  2053. { Old style object }
  2054. begin
  2055. { constructor with extended syntax called from new }
  2056. if (cnf_new_call in callnodeflags) then
  2057. vmttree:=cloadvmtaddrnode.create(ctypenode.create(methodpointer.resultdef))
  2058. else
  2059. { destructor with extended syntax called from dispose }
  2060. { value -1 is what fpc_help_constructor() changes VMT to when it allocates memory }
  2061. if (cnf_dispose_call in callnodeflags) then
  2062. vmttree:=cpointerconstnode.create(TConstPtrUInt(-1),voidpointertype)
  2063. else
  2064. { destructor called from exception block in constructor }
  2065. if (cnf_create_failed in callnodeflags) then
  2066. vmttree:=ctypeconvnode.create_internal(load_vmt_pointer_node,voidpointertype)
  2067. else
  2068. { inherited call, no create/destroy }
  2069. if (cnf_inherited in callnodeflags) then
  2070. vmttree:=cpointerconstnode.create(0,voidpointertype)
  2071. else
  2072. { do not create/destroy when called from member function
  2073. without specifying self explicit }
  2074. if (cnf_member_call in callnodeflags) then
  2075. begin
  2076. { destructor: don't release instance, vmt=0
  2077. constructor: don't initialize instance, vmt=0 }
  2078. vmttree:=cpointerconstnode.create(0,voidpointertype)
  2079. end
  2080. else
  2081. { normal object call like obj.proc }
  2082. begin
  2083. { destructor: direct call, no dispose, vmt=0
  2084. constructor: initialize object, load vmt }
  2085. if (procdefinition.proctypeoption=potype_constructor) then
  2086. begin
  2087. { old styled inherited call? }
  2088. if (methodpointer.nodetype=typen) then
  2089. vmttree:=cpointerconstnode.create(0,voidpointertype)
  2090. else
  2091. vmttree:=cloadvmtaddrnode.create(ctypenode.create(methodpointer.resultdef))
  2092. end
  2093. else
  2094. vmttree:=cpointerconstnode.create(0,voidpointertype);
  2095. end;
  2096. end;
  2097. result:=vmttree;
  2098. end;
  2099. function tcallnode.gen_block_context: tnode;
  2100. begin
  2101. { the self parameter of a block invocation is that address of the
  2102. block literal (which is what right contains) }
  2103. result:=right.getcopy;
  2104. end;
  2105. function check_funcret_used_as_para(var n: tnode; arg: pointer): foreachnoderesult;
  2106. var
  2107. destsym : tsym absolute arg;
  2108. begin
  2109. result := fen_false;
  2110. if (n.nodetype=loadn) and
  2111. (tloadnode(n).symtableentry = destsym) then
  2112. result := fen_norecurse_true;
  2113. end;
  2114. function tcallnode.funcret_can_be_reused:boolean;
  2115. var
  2116. realassignmenttarget: tnode;
  2117. alignment: longint;
  2118. begin
  2119. result:=false;
  2120. { we are processing an assignment node? }
  2121. if not(assigned(aktassignmentnode) and
  2122. (aktassignmentnode.right=self) and
  2123. (aktassignmentnode.left.resultdef=resultdef)) then
  2124. exit;
  2125. { destination must be able to be passed as var parameter }
  2126. if not valid_for_var(aktassignmentnode.left,false) then
  2127. exit;
  2128. { destination must be a simple load so it doesn't need a temp when
  2129. it is evaluated }
  2130. if not is_simple_para_load(aktassignmentnode.left,false) then
  2131. exit;
  2132. { remove possible typecasts }
  2133. realassignmenttarget:=actualtargetnode(@aktassignmentnode.left)^;
  2134. { when it is not passed in a parameter it will only be used after the
  2135. function call }
  2136. if not paramanager.ret_in_param(resultdef,procdefinition) then
  2137. begin
  2138. { don't replace the function result if we are inlining and if the destination is complex, this
  2139. could lead to lengthy code in case the function result is used often and it is assigned e.g.
  2140. to a threadvar }
  2141. result:=not(cnf_do_inline in callnodeflags) or
  2142. (node_complexity(aktassignmentnode.left)<=1);
  2143. exit;
  2144. end;
  2145. { if the result is the same as the self parameter (in case of objects),
  2146. we can't optimise. We have to check this explicitly becaise
  2147. hidden parameters such as self have not yet been inserted at this
  2148. point
  2149. }
  2150. if assigned(methodpointer) and
  2151. realassignmenttarget.isequal(actualtargetnode(@methodpointer)^) then
  2152. exit;
  2153. { when we substitute a function result inside an inlined function,
  2154. we may take the address of this function result. Therefore the
  2155. substituted function result may not be in a register, as we cannot
  2156. take its address in that case }
  2157. if (realassignmenttarget.nodetype=temprefn) and
  2158. not(ti_addr_taken in ttemprefnode(realassignmenttarget).tempinfo^.flags) and
  2159. not(ti_may_be_in_reg in ttemprefnode(realassignmenttarget).tempinfo^.flags) then
  2160. begin
  2161. result:=true;
  2162. exit;
  2163. end;
  2164. if (realassignmenttarget.nodetype=loadn) and
  2165. { nested procedures may access the current procedure's locals }
  2166. (procdefinition.parast.symtablelevel=normal_function_level) and
  2167. { must be a local variable, a value para or a hidden function result }
  2168. { parameter (which can be passed by address, but in that case it got }
  2169. { through these same checks at the caller side and is thus safe }
  2170. (
  2171. (tloadnode(realassignmenttarget).symtableentry.typ=localvarsym) or
  2172. (
  2173. (tloadnode(realassignmenttarget).symtableentry.typ=paravarsym) and
  2174. ((tparavarsym(tloadnode(realassignmenttarget).symtableentry).varspez = vs_value) or
  2175. (vo_is_funcret in tparavarsym(tloadnode(realassignmenttarget).symtableentry).varoptions))
  2176. )
  2177. ) and
  2178. { the address may not have been taken of the variable/parameter, because }
  2179. { otherwise it's possible that the called function can access it via a }
  2180. { global variable or other stored state }
  2181. (
  2182. not(tabstractvarsym(tloadnode(realassignmenttarget).symtableentry).addr_taken) and
  2183. (tabstractvarsym(tloadnode(realassignmenttarget).symtableentry).varregable in [vr_none,vr_addr])
  2184. ) then
  2185. begin
  2186. { If the funcret is also used as a parameter we can't optimize because the funcret
  2187. and the parameter will point to the same address. That means that a change of the result variable
  2188. will result also in a change of the parameter value }
  2189. result:=not foreachnodestatic(left,@check_funcret_used_as_para,tloadnode(realassignmenttarget).symtableentry);
  2190. { ensure that it is aligned using the default alignment }
  2191. alignment:=tabstractvarsym(tloadnode(realassignmenttarget).symtableentry).vardef.alignment;
  2192. if (used_align(alignment,target_info.alignment.localalignmin,target_info.alignment.localalignmax)<>
  2193. used_align(alignment,current_settings.alignment.localalignmin,current_settings.alignment.localalignmax)) then
  2194. result:=false;
  2195. exit;
  2196. end;
  2197. end;
  2198. procedure tcallnode.maybe_create_funcret_node;
  2199. var
  2200. temp : ttempcreatenode;
  2201. begin
  2202. if procdefinition.proctypeoption=potype_constructor then
  2203. exit;
  2204. { For the function result we need to create a temp node for:
  2205. - Inlined functions
  2206. - Types requiring initialization/finalization
  2207. - Types passed in parameters }
  2208. if not is_void(resultdef) and
  2209. not assigned(funcretnode) and
  2210. (
  2211. (cnf_do_inline in callnodeflags) or
  2212. is_managed_type(resultdef) or
  2213. paramanager.ret_in_param(resultdef,procdefinition)
  2214. ) then
  2215. begin
  2216. { Optimize calls like x:=f() where we can use x directly as
  2217. result instead of using a temp. Condition is that x cannot be accessed from f().
  2218. This implies that x is a local variable or value parameter of the current block
  2219. and its address is not passed to f. One problem: what if someone takes the
  2220. address of x, puts it in a pointer variable/field and then accesses it that way
  2221. from within the function? This is solved (in a conservative way) using the
  2222. ti_addr_taken flag.
  2223. When the result is not not passed in a parameter there are no problem because
  2224. then it means only reference counted types (eg. ansistrings) that need a decr
  2225. of the refcount before being assigned. This is all done after the call so there
  2226. is no issue with exceptions and possible use of the old value in the called
  2227. function }
  2228. if funcret_can_be_reused then
  2229. begin
  2230. funcretnode:=aktassignmentnode.left.getcopy;
  2231. include(funcretnode.flags,nf_is_funcret);
  2232. { notify the assignment node that the assignment can be removed }
  2233. include(aktassignmentnode.flags,nf_assign_done_in_right);
  2234. end
  2235. else
  2236. begin
  2237. temp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,
  2238. (cnf_do_inline in callnodeflags) and
  2239. not(tabstractvarsym(tprocdef(procdefinition).funcretsym).varregable in [vr_none,vr_addr]));
  2240. include(temp.flags,nf_is_funcret);
  2241. { if a managed type is returned by reference, assigning something
  2242. to the result on the caller side will take care of decreasing
  2243. the reference count }
  2244. if paramanager.ret_in_param(resultdef,procdefinition) then
  2245. include(temp.tempinfo^.flags,ti_nofini);
  2246. add_init_statement(temp);
  2247. { When the function result is not used in an inlined function
  2248. we need to delete the temp. This can currently only be done by
  2249. a tempdeletenode and not after converting it to a normal temp }
  2250. if not(cnf_return_value_used in callnodeflags) and
  2251. (cnf_do_inline in callnodeflags) then
  2252. add_done_statement(ctempdeletenode.create(temp))
  2253. else
  2254. add_done_statement(ctempdeletenode.create_normal_temp(temp));
  2255. funcretnode:=ctemprefnode.create(temp);
  2256. include(funcretnode.flags,nf_is_funcret);
  2257. end;
  2258. end;
  2259. end;
  2260. procedure tcallnode.gen_hidden_parameters;
  2261. var
  2262. para : tcallparanode;
  2263. begin
  2264. para:=tcallparanode(left);
  2265. while assigned(para) do
  2266. begin
  2267. { The processing of high() and typeinfo() is already
  2268. done in the typecheckpass. We only need to process the
  2269. nodes that still have a nothingn }
  2270. if (vo_is_hidden_para in para.parasym.varoptions) and
  2271. (para.left.nodetype=nothingn) then
  2272. begin
  2273. { remove dummy nothingn }
  2274. para.left.free;
  2275. para.left:=nil;
  2276. { generate the corresponding nodes for the hidden parameter type }
  2277. if (vo_is_funcret in para.parasym.varoptions) then
  2278. begin
  2279. if not assigned(funcretnode) then
  2280. internalerror(200709083);
  2281. para.left:=funcretnode;
  2282. funcretnode:=nil;
  2283. end
  2284. else
  2285. if vo_is_self in para.parasym.varoptions then
  2286. begin
  2287. if assigned(right) then
  2288. para.left:=gen_procvar_context_tree_self
  2289. else
  2290. para.left:=gen_self_tree;
  2291. { make sure that e.g. the self pointer of an advanced
  2292. record does not become a regvar, because it's a vs_var
  2293. parameter }
  2294. if paramanager.push_addr_param(para.parasym.varspez,para.parasym.vardef,
  2295. procdefinition.proccalloption) then
  2296. make_not_regable(para.left,[ra_addr_regable]);
  2297. end
  2298. else
  2299. if vo_is_vmt in para.parasym.varoptions then
  2300. begin
  2301. para.left:=gen_vmt_tree;
  2302. end
  2303. else
  2304. if vo_is_syscall_lib in para.parasym.varoptions then
  2305. gen_syscall_para(para)
  2306. else
  2307. if vo_is_parentfp in para.parasym.varoptions then
  2308. begin
  2309. if not assigned(right) then
  2310. begin
  2311. if assigned(procdefinition.owner.defowner) then
  2312. para.left:=cloadparentfpnode.create(tprocdef(procdefinition.owner.defowner))
  2313. { exceptfilters called from main level are not owned }
  2314. else if procdefinition.proctypeoption=potype_exceptfilter then
  2315. para.left:=cloadparentfpnode.create(current_procinfo.procdef)
  2316. else
  2317. internalerror(200309287);
  2318. end
  2319. else if not(po_is_block in procdefinition.procoptions) then
  2320. para.left:=gen_procvar_context_tree_parentfp
  2321. else
  2322. para.left:=gen_block_context
  2323. end
  2324. else
  2325. if vo_is_range_check in para.parasym.varoptions then
  2326. begin
  2327. para.left:=cordconstnode.create(Ord(cs_check_range in current_settings.localswitches),pasbool8type,false);
  2328. end
  2329. else
  2330. if vo_is_overflow_check in para.parasym.varoptions then
  2331. begin
  2332. para.left:=cordconstnode.create(Ord(cs_check_overflow in current_settings.localswitches),pasbool8type,false);
  2333. end
  2334. else
  2335. if vo_is_msgsel in para.parasym.varoptions then
  2336. begin
  2337. para.left:=cobjcselectornode.create(cstringconstnode.createstr(tprocdef(procdefinition).messageinf.str^));
  2338. end;
  2339. end;
  2340. if not assigned(para.left) then
  2341. internalerror(200709084);
  2342. para:=tcallparanode(para.right);
  2343. end;
  2344. end;
  2345. procedure tcallnode.verifyabstract(sym:TObject;arg:pointer);
  2346. var
  2347. pd : tprocdef;
  2348. i : longint;
  2349. j : integer;
  2350. hs : string;
  2351. begin
  2352. if (tsym(sym).typ<>procsym) then
  2353. exit;
  2354. for i:=0 to tprocsym(sym).ProcdefList.Count-1 do
  2355. begin
  2356. pd:=tprocdef(tprocsym(sym).ProcdefList[i]);
  2357. hs:=pd.procsym.name+pd.typename_paras([]);
  2358. j:=AbstractMethodsList.FindIndexOf(hs);
  2359. if j<>-1 then
  2360. AbstractMethodsList[j]:=pd
  2361. else
  2362. AbstractMethodsList.Add(hs,pd);
  2363. end;
  2364. end;
  2365. procedure tcallnode.verifyabstractcalls;
  2366. var
  2367. objectdf : tobjectdef;
  2368. parents : tlinkedlist;
  2369. objectinfo : tobjectinfoitem;
  2370. pd : tprocdef;
  2371. i : integer;
  2372. begin
  2373. objectdf := nil;
  2374. { verify if trying to create an instance of a class which contains
  2375. non-implemented abstract methods }
  2376. { first verify this class type, no class than exit }
  2377. { also, this checking can only be done if the constructor is directly
  2378. called, indirect constructor calls cannot be checked.
  2379. }
  2380. if assigned(methodpointer) and
  2381. not((methodpointer.nodetype=loadn) and
  2382. (loadnf_is_self in tloadnode(methodpointer).loadnodeflags)) then
  2383. begin
  2384. if (methodpointer.resultdef.typ = objectdef) then
  2385. objectdf:=tobjectdef(methodpointer.resultdef)
  2386. else
  2387. if (methodpointer.resultdef.typ = classrefdef) and
  2388. (tclassrefdef(methodpointer.resultdef).pointeddef.typ = objectdef) and
  2389. (methodpointer.nodetype in [typen,loadvmtaddrn]) then
  2390. objectdf:=tobjectdef(tclassrefdef(methodpointer.resultdef).pointeddef);
  2391. end;
  2392. if not assigned(objectdf) then
  2393. exit;
  2394. { quick exit if nothing to check }
  2395. if objectdf.abstractcnt = 0 then
  2396. exit;
  2397. parents := tlinkedlist.create;
  2398. AbstractMethodsList := TFPHashList.create;
  2399. { insert all parents in this class : the first item in the
  2400. list will be the base parent of the class .
  2401. }
  2402. while assigned(objectdf) do
  2403. begin
  2404. objectinfo:=tobjectinfoitem.create(objectdf);
  2405. parents.insert(objectinfo);
  2406. objectdf := objectdf.childof;
  2407. end;
  2408. { now all parents are in the correct order
  2409. insert all abstract methods in the list, and remove
  2410. those which are overridden by parent classes.
  2411. }
  2412. objectinfo:=tobjectinfoitem(parents.first);
  2413. while assigned(objectinfo) do
  2414. begin
  2415. objectdf := objectinfo.objinfo;
  2416. if assigned(objectdf.symtable) then
  2417. objectdf.symtable.SymList.ForEachCall(@verifyabstract,nil);
  2418. objectinfo:=tobjectinfoitem(objectinfo.next);
  2419. end;
  2420. if assigned(parents) then
  2421. parents.free;
  2422. { Finally give out a warning for each abstract method still in the list }
  2423. for i:=0 to AbstractMethodsList.Count-1 do
  2424. begin
  2425. pd:=tprocdef(AbstractMethodsList[i]);
  2426. if po_abstractmethod in pd.procoptions then
  2427. begin
  2428. Message2(type_w_instance_with_abstract,objectdf.objrealname^,pd.procsym.RealName);
  2429. MessagePos1(pd.fileinfo,sym_h_abstract_method_list,pd.fullprocname(true));
  2430. end;
  2431. end;
  2432. if assigned(AbstractMethodsList) then
  2433. AbstractMethodsList.Free;
  2434. end;
  2435. procedure tcallnode.convert_carg_array_of_const;
  2436. var
  2437. hp : tarrayconstructornode;
  2438. oldleft : tcallparanode;
  2439. begin
  2440. oldleft:=tcallparanode(left);
  2441. if oldleft.left.nodetype<>arrayconstructorn then
  2442. begin
  2443. CGMessage1(type_e_wrong_type_in_array_constructor,oldleft.left.resultdef.typename);
  2444. exit;
  2445. end;
  2446. include(callnodeflags,cnf_uses_varargs);
  2447. { Get arrayconstructor node and insert typeconvs }
  2448. hp:=tarrayconstructornode(oldleft.left);
  2449. { Add c args parameters }
  2450. { It could be an empty set }
  2451. if assigned(hp) and
  2452. assigned(hp.left) then
  2453. begin
  2454. while assigned(hp) do
  2455. begin
  2456. left:=ccallparanode.create(hp.left,left);
  2457. { set callparanode resultdef and flags }
  2458. left.resultdef:=hp.left.resultdef;
  2459. include(tcallparanode(left).callparaflags,cpf_varargs_para);
  2460. hp.left:=nil;
  2461. hp:=tarrayconstructornode(hp.right);
  2462. end;
  2463. end;
  2464. { Remove value of old array of const parameter, but keep it
  2465. in the list because it is required for bind_parasym.
  2466. Generate a nothign to keep callparanoed.left valid }
  2467. oldleft.left.free;
  2468. oldleft.left:=cnothingnode.create;
  2469. end;
  2470. procedure tcallnode.bind_parasym;
  2471. type
  2472. pcallparanode = ^tcallparanode;
  2473. var
  2474. i : integer;
  2475. pt : tcallparanode;
  2476. oldppt : pcallparanode;
  2477. varargspara,
  2478. currpara : tparavarsym;
  2479. hiddentree : tnode;
  2480. paradef : tdef;
  2481. begin
  2482. pt:=tcallparanode(left);
  2483. oldppt:=pcallparanode(@left);
  2484. { flag all callparanodes that belong to the varargs }
  2485. i:=paralength;
  2486. while (i>procdefinition.maxparacount) do
  2487. begin
  2488. include(pt.callparaflags,cpf_varargs_para);
  2489. oldppt:=pcallparanode(@pt.right);
  2490. pt:=tcallparanode(pt.right);
  2491. dec(i);
  2492. end;
  2493. { skip varargs that are inserted by array of const }
  2494. while assigned(pt) and
  2495. (cpf_varargs_para in pt.callparaflags) do
  2496. pt:=tcallparanode(pt.right);
  2497. { process normal parameters and insert hidden parameter nodes, the content
  2498. of the hidden parameters will be updated in pass1 }
  2499. for i:=procdefinition.paras.count-1 downto 0 do
  2500. begin
  2501. currpara:=tparavarsym(procdefinition.paras[i]);
  2502. if vo_is_hidden_para in currpara.varoptions then
  2503. begin
  2504. { Here we handle only the parameters that depend on
  2505. the types of the previous parameter. The typeconversion
  2506. can change the type in the next step. For example passing
  2507. an array can be change to a pointer and a deref }
  2508. if vo_is_high_para in currpara.varoptions then
  2509. begin
  2510. if not assigned(pt) or (i=0) then
  2511. internalerror(200304081);
  2512. { we need the information of the previous parameter }
  2513. paradef:=tparavarsym(procdefinition.paras[i-1]).vardef;
  2514. hiddentree:=gen_high_tree(pt.left,paradef);
  2515. { for open array of managed type, a copy of high parameter is
  2516. necessary to properly initialize before the call }
  2517. if is_open_array(paradef) and
  2518. (tparavarsym(procdefinition.paras[i-1]).varspez=vs_out) and
  2519. is_managed_type(tarraydef(paradef).elementdef) then
  2520. begin
  2521. typecheckpass(hiddentree);
  2522. {this eliminates double call to fpc_dynarray_high, if any}
  2523. maybe_load_in_temp(hiddentree);
  2524. oldppt^.third:=hiddentree.getcopy;
  2525. end;
  2526. end
  2527. else
  2528. if vo_is_typinfo_para in currpara.varoptions then
  2529. begin
  2530. if not assigned(pt) or (i=0) then
  2531. internalerror(200304082);
  2532. hiddentree:=caddrnode.create_internal(
  2533. crttinode.create(Tstoreddef(pt.resultdef),fullrtti,rdt_normal)
  2534. );
  2535. end
  2536. else
  2537. hiddentree:=cnothingnode.create;
  2538. pt:=ccallparanode.create(hiddentree,oldppt^);
  2539. oldppt^:=pt;
  2540. end;
  2541. if not assigned(pt) then
  2542. internalerror(200310052);
  2543. pt.parasym:=currpara;
  2544. oldppt:=pcallparanode(@pt.right);
  2545. pt:=tcallparanode(pt.right);
  2546. end;
  2547. { Create parasyms for varargs, first count the number of varargs paras,
  2548. then insert the parameters with numbering in reverse order. The SortParas
  2549. will set the correct order at the end}
  2550. pt:=tcallparanode(left);
  2551. i:=0;
  2552. while assigned(pt) do
  2553. begin
  2554. if cpf_varargs_para in pt.callparaflags then
  2555. inc(i);
  2556. pt:=tcallparanode(pt.right);
  2557. end;
  2558. if (i>0) then
  2559. begin
  2560. varargsparas:=tvarargsparalist.create;
  2561. pt:=tcallparanode(left);
  2562. while assigned(pt) do
  2563. begin
  2564. if cpf_varargs_para in pt.callparaflags then
  2565. begin
  2566. varargspara:=cparavarsym.create('va'+tostr(i),i,vs_value,pt.resultdef,[]);
  2567. dec(i);
  2568. { varargspara is left-right, use insert
  2569. instead of concat }
  2570. varargsparas.add(varargspara);
  2571. pt.parasym:=varargspara;
  2572. end;
  2573. pt:=tcallparanode(pt.right);
  2574. end;
  2575. varargsparas.sortparas;
  2576. end;
  2577. end;
  2578. function tcallnode.pass_typecheck:tnode;
  2579. var
  2580. candidates : tcallcandidates;
  2581. oldcallnode : tcallnode;
  2582. hpt : tnode;
  2583. pt : tcallparanode;
  2584. lastpara : longint;
  2585. paraidx,
  2586. cand_cnt : integer;
  2587. i : longint;
  2588. ignorevisibility,
  2589. is_const : boolean;
  2590. statements : tstatementnode;
  2591. converted_result_data : ttempcreatenode;
  2592. calltype: tdispcalltype;
  2593. label
  2594. errorexit;
  2595. begin
  2596. result:=nil;
  2597. candidates:=nil;
  2598. oldcallnode:=aktcallnode;
  2599. aktcallnode:=self;
  2600. { determine length of parameter list }
  2601. pt:=tcallparanode(left);
  2602. paralength:=0;
  2603. while assigned(pt) do
  2604. begin
  2605. inc(paralength);
  2606. pt:=tcallparanode(pt.right);
  2607. end;
  2608. { determine the type of the parameters }
  2609. if assigned(left) then
  2610. begin
  2611. tcallparanode(left).get_paratype;
  2612. if codegenerror then
  2613. goto errorexit;
  2614. end;
  2615. if assigned(methodpointer) then
  2616. typecheckpass(methodpointer);
  2617. { procedure variable ? }
  2618. if assigned(right) then
  2619. begin
  2620. set_varstate(right,vs_read,[vsf_must_be_valid]);
  2621. typecheckpass(right);
  2622. if codegenerror then
  2623. exit;
  2624. procdefinition:=tabstractprocdef(right.resultdef);
  2625. { Compare parameters from right to left }
  2626. paraidx:=procdefinition.Paras.count-1;
  2627. { Skip default parameters }
  2628. if not(po_varargs in procdefinition.procoptions) then
  2629. begin
  2630. { ignore hidden parameters }
  2631. while (paraidx>=0) and (vo_is_hidden_para in tparavarsym(procdefinition.paras[paraidx]).varoptions) do
  2632. dec(paraidx);
  2633. for i:=1 to procdefinition.maxparacount-paralength do
  2634. begin
  2635. if paraidx<0 then
  2636. internalerror(200402261);
  2637. if not assigned(tparavarsym(procdefinition.paras[paraidx]).defaultconstsym) then
  2638. begin
  2639. CGMessage1(parser_e_wrong_parameter_size,'<Procedure Variable>');
  2640. goto errorexit;
  2641. end;
  2642. dec(paraidx);
  2643. end;
  2644. end;
  2645. while (paraidx>=0) and (vo_is_hidden_para in tparavarsym(procdefinition.paras[paraidx]).varoptions) do
  2646. dec(paraidx);
  2647. pt:=tcallparanode(left);
  2648. lastpara:=paralength;
  2649. while (paraidx>=0) and assigned(pt) do
  2650. begin
  2651. { only goto next para if we're out of the varargs }
  2652. if not(po_varargs in procdefinition.procoptions) or
  2653. (lastpara<=procdefinition.maxparacount) then
  2654. begin
  2655. repeat
  2656. dec(paraidx);
  2657. until (paraidx<0) or not(vo_is_hidden_para in tparavarsym(procdefinition.paras[paraidx]).varoptions);
  2658. end;
  2659. pt:=tcallparanode(pt.right);
  2660. dec(lastpara);
  2661. end;
  2662. if assigned(pt) or
  2663. ((paraidx>=0) and
  2664. not assigned(tparavarsym(procdefinition.paras[paraidx]).defaultconstsym)) then
  2665. begin
  2666. if assigned(pt) then
  2667. current_filepos:=pt.fileinfo;
  2668. CGMessage1(parser_e_wrong_parameter_size,'<Procedure Variable>');
  2669. goto errorexit;
  2670. end;
  2671. end
  2672. else
  2673. { not a procedure variable }
  2674. begin
  2675. { do we know the procedure to call ? }
  2676. if not(assigned(procdefinition)) then
  2677. begin
  2678. { ignore possible private for properties or in delphi mode for anon. inherited (FK) }
  2679. ignorevisibility:=(nf_isproperty in flags) or
  2680. ((m_delphi in current_settings.modeswitches) and (cnf_anon_inherited in callnodeflags));
  2681. candidates:=tcallcandidates.create(symtableprocentry,symtableproc,left,ignorevisibility,
  2682. not(nf_isproperty in flags),cnf_objc_id_call in callnodeflags,cnf_unit_specified in callnodeflags,
  2683. callnodeflags*[cnf_anon_inherited,cnf_inherited]=[],cnf_anon_inherited in callnodeflags);
  2684. { no procedures found? then there is something wrong
  2685. with the parameter size or the procedures are
  2686. not accessible }
  2687. if candidates.count=0 then
  2688. begin
  2689. { when it's an auto inherited call and there
  2690. is no procedure found, but the procedures
  2691. were defined with overload directive and at
  2692. least two procedures are defined then we ignore
  2693. this inherited by inserting a nothingn. Only
  2694. do this ugly hack in Delphi mode as it looks more
  2695. like a bug. It's also not documented }
  2696. if (m_delphi in current_settings.modeswitches) and
  2697. (cnf_anon_inherited in callnodeflags) and
  2698. (symtableprocentry.owner.symtabletype=ObjectSymtable) and
  2699. (po_overload in tprocdef(symtableprocentry.ProcdefList[0]).procoptions) and
  2700. (symtableprocentry.ProcdefList.Count>=2) then
  2701. result:=cnothingnode.create
  2702. else
  2703. begin
  2704. { in tp mode we can try to convert to procvar if
  2705. there are no parameters specified }
  2706. if not(assigned(left)) and
  2707. not(cnf_inherited in callnodeflags) and
  2708. ((m_tp_procvar in current_settings.modeswitches) or
  2709. (m_mac_procvar in current_settings.modeswitches)) and
  2710. (not assigned(methodpointer) or
  2711. (methodpointer.nodetype <> typen)) then
  2712. begin
  2713. hpt:=cloadnode.create(tprocsym(symtableprocentry),symtableproc);
  2714. if assigned(methodpointer) then
  2715. tloadnode(hpt).set_mp(methodpointer.getcopy);
  2716. typecheckpass(hpt);
  2717. result:=hpt;
  2718. end
  2719. else
  2720. begin
  2721. CGMessagePos1(fileinfo,parser_e_wrong_parameter_size,symtableprocentry.realname);
  2722. symtableprocentry.write_parameter_lists(nil);
  2723. end;
  2724. end;
  2725. candidates.free;
  2726. goto errorexit;
  2727. end;
  2728. { Retrieve information about the candidates }
  2729. candidates.get_information;
  2730. {$ifdef EXTDEBUG}
  2731. { Display info when multiple candidates are found }
  2732. if candidates.count>1 then
  2733. candidates.dump_info(V_Debug);
  2734. {$endif EXTDEBUG}
  2735. { Choose the best candidate and count the number of
  2736. candidates left }
  2737. cand_cnt:=candidates.choose_best(procdefinition,
  2738. assigned(left) and
  2739. not assigned(tcallparanode(left).right) and
  2740. (tcallparanode(left).left.resultdef.typ=variantdef));
  2741. { All parameters are checked, check if there are any
  2742. procedures left }
  2743. if cand_cnt>0 then
  2744. begin
  2745. { Multiple candidates left? }
  2746. if cand_cnt>1 then
  2747. begin
  2748. CGMessage(type_e_cant_choose_overload_function);
  2749. {$ifdef EXTDEBUG}
  2750. candidates.dump_info(V_Hint);
  2751. {$else EXTDEBUG}
  2752. candidates.list(false);
  2753. {$endif EXTDEBUG}
  2754. { we'll just use the first candidate to make the
  2755. call }
  2756. end;
  2757. { assign procdefinition }
  2758. if symtableproc=nil then
  2759. symtableproc:=procdefinition.owner;
  2760. end
  2761. else
  2762. begin
  2763. { No candidates left, this must be a type error,
  2764. because wrong size is already checked. procdefinition
  2765. is filled with the first (random) definition that is
  2766. found. We use this definition to display a nice error
  2767. message that the wrong type is passed }
  2768. candidates.find_wrong_para;
  2769. candidates.list(true);
  2770. {$ifdef EXTDEBUG}
  2771. candidates.dump_info(V_Hint);
  2772. {$endif EXTDEBUG}
  2773. { We can not proceed, release all procs and exit }
  2774. candidates.free;
  2775. goto errorexit;
  2776. end;
  2777. candidates.free;
  2778. end; { end of procedure to call determination }
  2779. end;
  2780. { check for hints (deprecated etc) }
  2781. if procdefinition.typ = procdef then
  2782. check_hints(tprocdef(procdefinition).procsym,tprocdef(procdefinition).symoptions,tprocdef(procdefinition).deprecatedmsg);
  2783. { add reference to corresponding procsym; may not be the one
  2784. originally found/passed to the constructor because of overloads }
  2785. if procdefinition.typ = procdef then
  2786. addsymref(tprocdef(procdefinition).procsym);
  2787. { add needed default parameters }
  2788. if (paralength<procdefinition.maxparacount) then
  2789. begin
  2790. paraidx:=0;
  2791. i:=0;
  2792. while (i<paralength) do
  2793. begin
  2794. if paraidx>=procdefinition.Paras.count then
  2795. internalerror(200306181);
  2796. if not(vo_is_hidden_para in tparavarsym(procdefinition.paras[paraidx]).varoptions) then
  2797. inc(i);
  2798. inc(paraidx);
  2799. end;
  2800. while (paraidx<procdefinition.paras.count) and (vo_is_hidden_para in tparavarsym(procdefinition.paras[paraidx]).varoptions) do
  2801. inc(paraidx);
  2802. while (paraidx<procdefinition.paras.count) do
  2803. begin
  2804. if not assigned(tparavarsym(procdefinition.paras[paraidx]).defaultconstsym) then
  2805. internalerror(200212142);
  2806. left:=ccallparanode.create(genconstsymtree(
  2807. tconstsym(tparavarsym(procdefinition.paras[paraidx]).defaultconstsym)),left);
  2808. { Ignore vs_hidden parameters }
  2809. repeat
  2810. inc(paraidx);
  2811. until (paraidx>=procdefinition.paras.count) or
  2812. not(vo_is_hidden_para in tparavarsym(procdefinition.paras[paraidx]).varoptions);
  2813. end;
  2814. end;
  2815. { recursive call? }
  2816. if assigned(current_procinfo) and
  2817. (procdefinition=current_procinfo.procdef) then
  2818. include(current_procinfo.flags,pi_is_recursive);
  2819. { handle predefined procedures }
  2820. is_const:=(po_internconst in procdefinition.procoptions) and
  2821. ((block_type in [bt_const,bt_type,bt_const_type,bt_var_type]) or
  2822. (assigned(left) and ((tcallparanode(left).left.nodetype in [realconstn,ordconstn])
  2823. and (not assigned(tcallparanode(left).right) or (tcallparanode(left).right.nodetype in [realconstn,ordconstn])))));
  2824. if (procdefinition.proccalloption=pocall_internproc) or is_const then
  2825. begin
  2826. if assigned(left) then
  2827. begin
  2828. { convert types to those of the prototype, this is required by functions like ror, rol, sar
  2829. some use however a dummy type (Typedfile) so this would break them }
  2830. if not(tprocdef(procdefinition).extnumber in [fpc_in_Reset_TypedFile,fpc_in_Rewrite_TypedFile]) then
  2831. begin
  2832. { bind parasyms to the callparanodes and insert hidden parameters }
  2833. bind_parasym;
  2834. { insert type conversions for parameters }
  2835. if assigned(left) then
  2836. tcallparanode(left).insert_typeconv;
  2837. end;
  2838. { ptr and settextbuf need two args }
  2839. if assigned(tcallparanode(left).right) then
  2840. begin
  2841. hpt:=geninlinenode(tprocdef(procdefinition).extnumber,is_const,left);
  2842. left:=nil;
  2843. end
  2844. else
  2845. begin
  2846. hpt:=geninlinenode(tprocdef(procdefinition).extnumber,is_const,tcallparanode(left).left);
  2847. tcallparanode(left).left:=nil;
  2848. end;
  2849. end
  2850. else
  2851. hpt:=geninlinenode(tprocdef(procdefinition).extnumber,is_const,nil);
  2852. result:=hpt;
  2853. goto errorexit;
  2854. end;
  2855. { ensure that the result type is set }
  2856. if not(cnf_typedefset in callnodeflags) then
  2857. begin
  2858. { constructors return their current class type, not the type where the
  2859. constructor is declared, this can be different because of inheritance }
  2860. if (procdefinition.proctypeoption=potype_constructor) and
  2861. assigned(methodpointer) and
  2862. assigned(methodpointer.resultdef) and
  2863. (methodpointer.resultdef.typ=classrefdef) then
  2864. resultdef:=tclassrefdef(methodpointer.resultdef).pointeddef
  2865. else
  2866. { Member call to a (inherited) constructor from the class, the return
  2867. value is always self, so we change it to voidtype to generate an
  2868. error and to prevent users from generating non-working code
  2869. when they expect to clone the current instance, see bug 3662 (PFV) }
  2870. if (procdefinition.proctypeoption=potype_constructor) and
  2871. is_class(tprocdef(procdefinition).struct) and
  2872. assigned(methodpointer) and
  2873. (methodpointer.nodetype=loadn) and
  2874. (loadnf_is_self in tloadnode(methodpointer).loadnodeflags) then
  2875. resultdef:=voidtype
  2876. else
  2877. resultdef:=procdefinition.returndef;
  2878. end
  2879. else
  2880. resultdef:=typedef;
  2881. { Check object/class for methods }
  2882. if assigned(methodpointer) then
  2883. begin
  2884. { direct call to inherited abstract method, then we
  2885. can already give a error in the compiler instead
  2886. of a runtime error }
  2887. if (cnf_inherited in callnodeflags) and
  2888. (po_abstractmethod in procdefinition.procoptions) then
  2889. begin
  2890. if (m_delphi in current_settings.modeswitches) and
  2891. (cnf_anon_inherited in callnodeflags) then
  2892. begin
  2893. CGMessage(cg_h_inherited_ignored);
  2894. result:=cnothingnode.create;
  2895. exit;
  2896. end
  2897. else
  2898. CGMessage(cg_e_cant_call_abstract_method);
  2899. end;
  2900. { directly calling an interface/protocol/category/class helper
  2901. method via its type is not possible (always must be called via
  2902. the actual instance) }
  2903. if (methodpointer.nodetype=typen) and
  2904. (is_interface(methodpointer.resultdef) or
  2905. is_objc_protocol_or_category(methodpointer.resultdef)) then
  2906. CGMessage1(type_e_class_type_expected,methodpointer.resultdef.typename);
  2907. { if an inherited con- or destructor should be }
  2908. { called in a con- or destructor then a warning }
  2909. { will be made }
  2910. { con- and destructors need a pointer to the vmt }
  2911. if (cnf_inherited in callnodeflags) and
  2912. (procdefinition.proctypeoption in [potype_constructor,potype_destructor]) and
  2913. is_object(methodpointer.resultdef) and
  2914. not(current_procinfo.procdef.proctypeoption in [potype_constructor,potype_destructor]) then
  2915. CGMessage(cg_w_member_cd_call_from_method);
  2916. if methodpointer.nodetype<>typen then
  2917. begin
  2918. { Remove all postfix operators }
  2919. hpt:=methodpointer;
  2920. while assigned(hpt) and (hpt.nodetype in [subscriptn,vecn]) do
  2921. hpt:=tunarynode(hpt).left;
  2922. if ((hpt.nodetype=loadvmtaddrn) or
  2923. ((hpt.nodetype=loadn) and assigned(tloadnode(hpt).resultdef) and (tloadnode(hpt).resultdef.typ=classrefdef))) and
  2924. not (procdefinition.proctypeoption=potype_constructor) and
  2925. not (po_classmethod in procdefinition.procoptions) and
  2926. not (po_staticmethod in procdefinition.procoptions) then
  2927. { error: we are calling instance method from the class method/static method }
  2928. CGMessage(parser_e_only_class_members);
  2929. if (procdefinition.proctypeoption=potype_constructor) and
  2930. assigned(symtableproc) and
  2931. (symtableproc.symtabletype=withsymtable) and
  2932. (tnode(twithsymtable(symtableproc).withrefnode).nodetype=temprefn) then
  2933. CGmessage(cg_e_cannot_call_cons_dest_inside_with);
  2934. { skip (absolute and other simple) type conversions -- only now,
  2935. because the checks above have to take type conversions into
  2936. e.g. class reference types account }
  2937. hpt:=actualtargetnode(@hpt)^;
  2938. { R.Init then R will be initialized by the constructor,
  2939. Also allow it for simple loads }
  2940. if (procdefinition.proctypeoption=potype_constructor) or
  2941. ((hpt.nodetype=loadn) and
  2942. (((methodpointer.resultdef.typ=objectdef) and
  2943. not(oo_has_virtual in tobjectdef(methodpointer.resultdef).objectoptions)) or
  2944. (methodpointer.resultdef.typ=recorddef)
  2945. )
  2946. ) then
  2947. { a constructor will and a method may write something to }
  2948. { the fields }
  2949. set_varstate(methodpointer,vs_readwritten,[])
  2950. else
  2951. set_varstate(methodpointer,vs_read,[vsf_must_be_valid]);
  2952. end;
  2953. { if we are calling the constructor check for abstract
  2954. methods. Ignore inherited and member calls, because the
  2955. class is then already created }
  2956. if (procdefinition.proctypeoption=potype_constructor) and
  2957. not(cnf_inherited in callnodeflags) and
  2958. not(cnf_member_call in callnodeflags) then
  2959. verifyabstractcalls;
  2960. end
  2961. else
  2962. begin
  2963. { When this is method the methodpointer must be available }
  2964. if (right=nil) and
  2965. (procdefinition.owner.symtabletype in [ObjectSymtable,recordsymtable]) and
  2966. not procdefinition.no_self_node then
  2967. internalerror(200305061);
  2968. end;
  2969. { Set flag that the procedure uses varargs, also if they are not passed it is still
  2970. needed for x86_64 to pass the number of SSE registers used }
  2971. if po_varargs in procdefinition.procoptions then
  2972. include(callnodeflags,cnf_uses_varargs);
  2973. { set the appropriate node flag if the call never returns }
  2974. if po_noreturn in procdefinition.procoptions then
  2975. include(callnodeflags,cnf_call_never_returns);
  2976. { Change loading of array of const to varargs }
  2977. if assigned(left) and
  2978. is_array_of_const(tparavarsym(procdefinition.paras[procdefinition.paras.count-1]).vardef) and
  2979. (procdefinition.proccalloption in cdecl_pocalls) then
  2980. convert_carg_array_of_const;
  2981. { bind parasyms to the callparanodes and insert hidden parameters }
  2982. bind_parasym;
  2983. { insert type conversions for parameters }
  2984. if assigned(left) then
  2985. tcallparanode(left).insert_typeconv;
  2986. { dispinterface methode invoke? }
  2987. if assigned(methodpointer) and is_dispinterface(methodpointer.resultdef) then
  2988. begin
  2989. case procdefinition.proctypeoption of
  2990. potype_propgetter: calltype:=dct_propget;
  2991. potype_propsetter: calltype:=dct_propput;
  2992. else
  2993. calltype:=dct_method;
  2994. end;
  2995. { if the result is used, we've to insert a call to convert the type to be on the "safe side" }
  2996. if (cnf_return_value_used in callnodeflags) and not is_void(procdefinition.returndef) then
  2997. begin
  2998. result:=internalstatements(statements);
  2999. converted_result_data:=ctempcreatenode.create(procdefinition.returndef,sizeof(procdefinition.returndef),
  3000. tt_persistent,true);
  3001. addstatement(statements,converted_result_data);
  3002. addstatement(statements,cassignmentnode.create(ctemprefnode.create(converted_result_data),
  3003. ctypeconvnode.create_internal(
  3004. translate_disp_call(methodpointer,parameters,calltype,'',tprocdef(procdefinition).dispid,procdefinition.returndef),
  3005. procdefinition.returndef)));
  3006. addstatement(statements,ctempdeletenode.create_normal_temp(converted_result_data));
  3007. addstatement(statements,ctemprefnode.create(converted_result_data));
  3008. end
  3009. else
  3010. result:=translate_disp_call(methodpointer,parameters,calltype,'',tprocdef(procdefinition).dispid,voidtype);
  3011. { don't free reused nodes }
  3012. methodpointer:=nil;
  3013. parameters:=nil;
  3014. end;
  3015. errorexit:
  3016. aktcallnode:=oldcallnode;
  3017. end;
  3018. procedure tcallnode.order_parameters;
  3019. var
  3020. hp,hpcurr,hpnext,hpfirst,hpprev : tcallparanode;
  3021. currloc : tcgloc;
  3022. begin
  3023. hpfirst:=nil;
  3024. hpcurr:=tcallparanode(left);
  3025. { cache all info about parameters containing stack tainting calls,
  3026. since we will need it a lot below and calculting it can be expensive }
  3027. while assigned(hpcurr) do
  3028. begin
  3029. hpcurr.init_contains_stack_tainting_call_cache;
  3030. hpcurr:=tcallparanode(hpcurr.right);
  3031. end;
  3032. hpcurr:=tcallparanode(left);
  3033. while assigned(hpcurr) do
  3034. begin
  3035. { pull out }
  3036. hpnext:=tcallparanode(hpcurr.right);
  3037. { pull in at the correct place.
  3038. Used order:
  3039. 1. LOC_REFERENCE with smallest offset (i386 only)
  3040. 2. LOC_REFERENCE with least complexity (non-i386 only)
  3041. 3. LOC_REFERENCE with most complexity (non-i386 only)
  3042. 4. LOC_REGISTER with most complexity
  3043. 5. LOC_REGISTER with least complexity
  3044. For the moment we only look at the first parameter field. Combining it
  3045. with multiple parameter fields will make things a lot complexer (PFV)
  3046. The reason for the difference regarding complexity ordering
  3047. between LOC_REFERENCE and LOC_REGISTER is mainly for calls:
  3048. we first want to treat the LOC_REFERENCE destinations whose
  3049. calculation does not require a call, because their location
  3050. may contain registers which might otherwise have to be saved
  3051. if a call has to be evaluated first. The calculated value is
  3052. stored on the stack and will thus no longer occupy any
  3053. register.
  3054. Similarly, for the register parameters we first want to
  3055. evaluate the calls, because otherwise the already loaded
  3056. register parameters will have to be saved so the intermediate
  3057. call can be evaluated (JM) }
  3058. if not assigned(hpcurr.parasym.paraloc[callerside].location) then
  3059. internalerror(200412152);
  3060. currloc:=hpcurr.parasym.paraloc[callerside].location^.loc;
  3061. hpprev:=nil;
  3062. hp:=hpfirst;
  3063. { on fixed_stack targets, always evaluate parameters containing
  3064. a call with stack parameters before all other parameters,
  3065. because they will prevent any other parameters from being put
  3066. in their final place; if both the current and the next para
  3067. contain a stack tainting call, don't do anything to prevent
  3068. them from keeping on chasing eachother's tail }
  3069. while assigned(hp) do
  3070. begin
  3071. if paramanager.use_fixed_stack and
  3072. hpcurr.contains_stack_tainting_call_cached then
  3073. break;
  3074. case currloc of
  3075. LOC_REFERENCE :
  3076. begin
  3077. case hp.parasym.paraloc[callerside].location^.loc of
  3078. LOC_REFERENCE :
  3079. begin
  3080. { Offset is calculated like:
  3081. sub esp,12
  3082. mov [esp+8],para3
  3083. mov [esp+4],para2
  3084. mov [esp],para1
  3085. call function
  3086. That means the for pushes the para with the
  3087. highest offset (see para3) needs to be pushed first
  3088. }
  3089. {$if defined(i386) or defined(i8086) or defined(m68k)}
  3090. { the i386, i8086, m68k and jvm code generators expect all reference }
  3091. { parameters to be in this order so they can use }
  3092. { pushes in case of no fixed stack }
  3093. if (not paramanager.use_fixed_stack and
  3094. (hpcurr.parasym.paraloc[callerside].location^.reference.offset>
  3095. hp.parasym.paraloc[callerside].location^.reference.offset)) or
  3096. (paramanager.use_fixed_stack and
  3097. (node_complexity(hpcurr)<node_complexity(hp))) then
  3098. {$elseif defined(jvm)}
  3099. if (hpcurr.parasym.paraloc[callerside].location^.reference.offset<hp.parasym.paraloc[callerside].location^.reference.offset) then
  3100. {$else jvm}
  3101. if (node_complexity(hpcurr)<node_complexity(hp)) then
  3102. {$endif jvm}
  3103. break;
  3104. end;
  3105. LOC_MMREGISTER,
  3106. LOC_REGISTER,
  3107. LOC_FPUREGISTER :
  3108. break;
  3109. end;
  3110. end;
  3111. LOC_MMREGISTER,
  3112. LOC_FPUREGISTER,
  3113. LOC_REGISTER :
  3114. begin
  3115. if (hp.parasym.paraloc[callerside].location^.loc<>LOC_REFERENCE) and
  3116. (node_complexity(hpcurr)>node_complexity(hp)) then
  3117. break;
  3118. end;
  3119. end;
  3120. hpprev:=hp;
  3121. hp:=tcallparanode(hp.right);
  3122. end;
  3123. hpcurr.right:=hp;
  3124. if assigned(hpprev) then
  3125. hpprev.right:=hpcurr
  3126. else
  3127. hpfirst:=hpcurr;
  3128. { next }
  3129. hpcurr:=hpnext;
  3130. end;
  3131. left:=hpfirst;
  3132. { now mark each parameter that is followed by a stack-tainting call,
  3133. to determine on use_fixed_stack targets which ones can immediately be
  3134. put in their final destination. Unforunately we can never put register
  3135. parameters immediately in their final destination (even on register-
  3136. rich architectures such as the PowerPC), because the code generator
  3137. can still insert extra calls that only make use of register
  3138. parameters (fpc_move() etc. }
  3139. hpcurr:=hpfirst;
  3140. while assigned(hpcurr) do
  3141. begin
  3142. if hpcurr.contains_stack_tainting_call_cached then
  3143. begin
  3144. { all parameters before this one are followed by a stack
  3145. tainting call }
  3146. hp:=hpfirst;
  3147. while hp<>hpcurr do
  3148. begin
  3149. hp.ffollowed_by_stack_tainting_call_cached:=true;
  3150. hp:=tcallparanode(hp.right);
  3151. end;
  3152. hpfirst:=hpcurr;
  3153. end;
  3154. hpcurr:=tcallparanode(hpcurr.right);
  3155. end;
  3156. end;
  3157. procedure tcallnode.check_stack_parameters;
  3158. var
  3159. hp : tcallparanode;
  3160. begin
  3161. hp:=tcallparanode(left);
  3162. while assigned(hp) do
  3163. begin
  3164. if assigned(hp.parasym) and
  3165. assigned(hp.parasym.paraloc[callerside].location) and
  3166. (hp.parasym.paraloc[callerside].location^.loc=LOC_REFERENCE) then
  3167. include(current_procinfo.flags,pi_has_stackparameter);
  3168. hp:=tcallparanode(hp.right);
  3169. end;
  3170. end;
  3171. procedure tcallnode.check_inlining;
  3172. var
  3173. st : tsymtable;
  3174. para : tcallparanode;
  3175. begin
  3176. { Can we inline the procedure? }
  3177. if (po_inline in procdefinition.procoptions) and
  3178. (procdefinition.typ=procdef) and
  3179. tprocdef(procdefinition).has_inlininginfo then
  3180. begin
  3181. include(callnodeflags,cnf_do_inline);
  3182. { Check if we can inline the procedure when it references proc/var that
  3183. are not in the globally available }
  3184. st:=procdefinition.owner;
  3185. while (st.symtabletype in [ObjectSymtable,recordsymtable]) do
  3186. st:=st.defowner.owner;
  3187. if (pi_uses_static_symtable in tprocdef(procdefinition).inlininginfo^.flags) and
  3188. (st.symtabletype=globalsymtable) and
  3189. (not st.iscurrentunit) then
  3190. begin
  3191. Comment(V_lineinfo+V_Debug,'Not inlining "'+tprocdef(procdefinition).procsym.realname+'", references static symtable');
  3192. exclude(callnodeflags,cnf_do_inline);
  3193. end;
  3194. para:=tcallparanode(parameters);
  3195. while assigned(para) do
  3196. begin
  3197. if not para.can_be_inlined then
  3198. begin
  3199. Comment(V_lineinfo+V_Debug,'Not inlining "'+tprocdef(procdefinition).procsym.realname+
  3200. '", invocation parameter contains an unsafe/unsupported construct');
  3201. exclude(callnodeflags,cnf_do_inline);
  3202. break;
  3203. end;
  3204. para:=tcallparanode(para.nextpara);
  3205. end;
  3206. end;
  3207. end;
  3208. function tcallnode.pass_1 : tnode;
  3209. procedure mark_unregable_parameters;
  3210. var
  3211. hp : tcallparanode;
  3212. begin
  3213. hp:=tcallparanode(left);
  3214. while assigned(hp) do
  3215. begin
  3216. do_typecheckpass(hp.left);
  3217. { When the address needs to be pushed then the register is
  3218. not regable. Exception is when the location is also a var
  3219. parameter and we can pass the address transparently (but
  3220. that is handled by make_not_regable if ra_addr_regable is
  3221. passed, and make_not_regable always needs to called for
  3222. the ra_addr_taken info for non-invisble parameters) }
  3223. if (not (cpf_varargs_para in hp.callparaflags)) and (
  3224. not(
  3225. (vo_is_hidden_para in hp.parasym.varoptions) and
  3226. (hp.left.resultdef.typ in [pointerdef,classrefdef])
  3227. ) and
  3228. paramanager.push_addr_param(hp.parasym.varspez,hp.parasym.vardef,
  3229. self.procdefinition.proccalloption)
  3230. ) then
  3231. { pushing the address of a variable to take the place of a temp
  3232. as the complex function result of a function does not make its
  3233. address escape the current block, as the "address of the
  3234. function result" is not something which can be stored
  3235. persistently by the callee (it becomes invalid when the callee
  3236. returns) }
  3237. if not(vo_is_funcret in hp.parasym.varoptions) then
  3238. make_not_regable(hp.left,[ra_addr_regable,ra_addr_taken])
  3239. else
  3240. make_not_regable(hp.left,[ra_addr_regable]);
  3241. hp:=tcallparanode(hp.right);
  3242. end;
  3243. end;
  3244. var
  3245. para: tcallparanode;
  3246. begin
  3247. result:=nil;
  3248. { as pass_1 is never called on the methodpointer node, we must check
  3249. here that it's not a helper type }
  3250. if assigned(methodpointer) and
  3251. (methodpointer.nodetype=typen) and
  3252. is_objectpascal_helper(ttypenode(methodpointer).typedef) and
  3253. not ttypenode(methodpointer).helperallowed then
  3254. Message(parser_e_no_category_as_types);
  3255. { can we get rid of the call? }
  3256. if (cs_opt_remove_emtpy_proc in current_settings.optimizerswitches) and
  3257. not(cnf_return_value_used in callnodeflags) and
  3258. (procdefinition.typ=procdef) and
  3259. tprocdef(procdefinition).isempty and
  3260. { allow only certain proc options }
  3261. ((tprocdef(procdefinition).procoptions-[po_none,po_classmethod,po_staticmethod,
  3262. po_interrupt,po_iocheck,po_assembler,po_msgstr,po_msgint,po_exports,po_external,po_overload,
  3263. po_nostackframe,po_has_mangledname,po_has_public_name,po_forward,po_global,
  3264. po_inline,po_compilerproc,po_has_importdll,po_has_importname,po_kylixlocal,po_dispid,po_delphi_nested_cc,
  3265. po_rtlproc,po_ignore_for_overload_resolution,po_auto_raised_visibility])=[]) then
  3266. begin
  3267. { check parameters for side effects }
  3268. para:=tcallparanode(left);
  3269. while assigned(para) do
  3270. begin
  3271. if (para.parasym.typ = paravarsym) and
  3272. ((para.parasym.refs>0) or
  3273. { array of consts are converted later on so we need to skip them here
  3274. else no error detection is done }
  3275. is_array_of_const(para.parasym.vardef) or
  3276. not(cs_opt_dead_values in current_settings.optimizerswitches) or
  3277. might_have_sideeffects(para.left)) then
  3278. break;
  3279. para:=tcallparanode(para.right);
  3280. end;
  3281. { finally, remove it if no parameter with side effect has been found }
  3282. if para=nil then
  3283. begin
  3284. result:=cnothingnode.create;
  3285. exit;
  3286. end;
  3287. end;
  3288. { convert Objective-C calls into a message call }
  3289. if (procdefinition.typ=procdef) and
  3290. (po_objc in tprocdef(procdefinition).procoptions) then
  3291. begin
  3292. if not(cnf_objc_processed in callnodeflags) then
  3293. objc_convert_to_message_send;
  3294. end
  3295. else
  3296. begin
  3297. { The following don't apply to obj-c: obj-c methods can never be
  3298. inlined because they're always virtual and the destination can
  3299. change at run, and for the same reason we also can't perform
  3300. WPO on them (+ they have no constructors) }
  3301. { Check if the call can be inlined, sets the cnf_do_inline flag }
  3302. check_inlining;
  3303. { must be called before maybe_load_in_temp(methodpointer), because
  3304. it converts the methodpointer into a temp in case it's a call
  3305. (and we want to know the original call)
  3306. }
  3307. register_created_object_types;
  3308. end;
  3309. { Maybe optimize the loading of the methodpointer using a temp. When the methodpointer
  3310. is a calln this is even required to not execute the calln twice.
  3311. This needs to be done after the resulttype pass, because in the resulttype we can still convert the
  3312. calln to a loadn (PFV) }
  3313. if assigned(methodpointer) then
  3314. maybe_load_in_temp(methodpointer);
  3315. { Create destination (temp or assignment-variable reuse) for function result if it not yet set }
  3316. maybe_create_funcret_node;
  3317. { Insert the self,vmt,function result in the parameters }
  3318. gen_hidden_parameters;
  3319. { Remove useless nodes from init/final blocks }
  3320. { (simplify depends on typecheck info) }
  3321. if assigned(callinitblock) then
  3322. begin
  3323. typecheckpass(tnode(callinitblock));
  3324. doinlinesimplify(tnode(callinitblock));
  3325. end;
  3326. if assigned(callcleanupblock) then
  3327. begin
  3328. typecheckpass(tnode(callcleanupblock));
  3329. doinlinesimplify(tnode(callcleanupblock));
  3330. end;
  3331. { If a constructor calls another constructor of the same or of an
  3332. inherited class, some targets (jvm) have to generate different
  3333. entry code for the constructor. }
  3334. if (current_procinfo.procdef.proctypeoption=potype_constructor) and
  3335. (procdefinition.typ=procdef) and
  3336. (tprocdef(procdefinition).proctypeoption=potype_constructor) and
  3337. ([cnf_member_call,cnf_inherited] * callnodeflags <> []) then
  3338. current_procinfo.ConstructorCallingConstructor:=true;
  3339. { object check helper will load VMT -> needs GOT }
  3340. if (cs_check_object in current_settings.localswitches) and
  3341. (cs_create_pic in current_settings.moduleswitches) then
  3342. include(current_procinfo.flags,pi_needs_got);
  3343. { Continue with checking a normal call or generate the inlined code }
  3344. if cnf_do_inline in callnodeflags then
  3345. result:=pass1_inline
  3346. else
  3347. begin
  3348. mark_unregable_parameters;
  3349. result:=pass1_normal;
  3350. end;
  3351. end;
  3352. function tcallnode.pass1_normal : tnode;
  3353. begin
  3354. result:=nil;
  3355. { calculate the parameter info for the procdef }
  3356. procdefinition.init_paraloc_info(callerside);
  3357. { calculate the parameter size needed for this call include varargs if they are available }
  3358. if assigned(varargsparas) then
  3359. pushedparasize:=paramanager.create_varargs_paraloc_info(procdefinition,varargsparas)
  3360. else
  3361. pushedparasize:=procdefinition.callerargareasize;
  3362. { record maximum parameter size used in this proc }
  3363. current_procinfo.allocate_push_parasize(pushedparasize);
  3364. { check for stacked parameters }
  3365. if assigned(left) and
  3366. (current_settings.optimizerswitches*[cs_opt_stackframe,cs_opt_level1]<>[]) then
  3367. check_stack_parameters;
  3368. if assigned(callinitblock) then
  3369. firstpass(tnode(callinitblock));
  3370. { function result node (tempref or simple load) }
  3371. if assigned(funcretnode) then
  3372. firstpass(funcretnode);
  3373. { parameters }
  3374. if assigned(left) then
  3375. tcallparanode(left).firstcallparan;
  3376. { procedure variable ? }
  3377. if assigned(right) then
  3378. firstpass(right);
  3379. if assigned(methodpointer) and
  3380. (methodpointer.nodetype<>typen) then
  3381. firstpass(methodpointer);
  3382. if assigned(callcleanupblock) then
  3383. firstpass(tnode(callcleanupblock));
  3384. if not (block_type in [bt_const,bt_type,bt_const_type,bt_var_type]) then
  3385. include(current_procinfo.flags,pi_do_call);
  3386. { order parameters }
  3387. order_parameters;
  3388. { get a register for the return value }
  3389. if (not is_void(resultdef)) then
  3390. begin
  3391. if paramanager.ret_in_param(resultdef,procdefinition) then
  3392. begin
  3393. expectloc:=LOC_REFERENCE;
  3394. end
  3395. else
  3396. { ansi/widestrings must be registered, so we can dispose them }
  3397. if is_ansistring(resultdef) or
  3398. is_widestring(resultdef) or
  3399. is_unicodestring(resultdef) then
  3400. begin
  3401. expectloc:=LOC_REFERENCE;
  3402. end
  3403. else
  3404. { we have only to handle the result if it is used }
  3405. if (cnf_return_value_used in callnodeflags) then
  3406. expectloc:=get_expect_loc
  3407. else
  3408. expectloc:=LOC_VOID;
  3409. end
  3410. else
  3411. expectloc:=LOC_VOID;
  3412. end;
  3413. {$ifdef state_tracking}
  3414. function Tcallnode.track_state_pass(exec_known:boolean):boolean;
  3415. var hp:Tcallparanode;
  3416. value:Tnode;
  3417. begin
  3418. track_state_pass:=false;
  3419. hp:=Tcallparanode(left);
  3420. while assigned(hp) do
  3421. begin
  3422. if left.track_state_pass(exec_known) then
  3423. begin
  3424. left.resultdef:=nil;
  3425. do_typecheckpass(left);
  3426. end;
  3427. value:=aktstate.find_fact(hp.left);
  3428. if value<>nil then
  3429. begin
  3430. track_state_pass:=true;
  3431. hp.left.destroy;
  3432. hp.left:=value.getcopy;
  3433. do_typecheckpass(hp.left);
  3434. end;
  3435. hp:=Tcallparanode(hp.right);
  3436. end;
  3437. end;
  3438. {$endif}
  3439. {**************************************************************************
  3440. INLINING SUPPORT
  3441. **************************************************************************}
  3442. function tcallnode.replaceparaload(var n: tnode; arg: pointer): foreachnoderesult;
  3443. var
  3444. paras: tcallparanode;
  3445. temp: tnode;
  3446. indexnr : integer;
  3447. begin
  3448. result := fen_false;
  3449. n.fileinfo := pfileposinfo(arg)^;
  3450. if (n.nodetype = loadn) then
  3451. begin
  3452. case tloadnode(n).symtableentry.typ of
  3453. paravarsym :
  3454. begin
  3455. paras := tcallparanode(left);
  3456. while assigned(paras) and
  3457. (paras.parasym <> tloadnode(n).symtableentry) do
  3458. paras := tcallparanode(paras.right);
  3459. if assigned(paras) then
  3460. begin
  3461. temp:=paras.left.getcopy;
  3462. { inherit modification information, this is needed by the dfa/cse }
  3463. temp.flags:=temp.flags+(n.flags*[nf_modify,nf_write,nf_address_taken]);
  3464. n.free;
  3465. n:=temp;
  3466. typecheckpass(n);
  3467. result := fen_true;
  3468. end;
  3469. end;
  3470. localvarsym :
  3471. begin
  3472. { local? }
  3473. if (tloadnode(n).symtableentry.owner <> tprocdef(procdefinition).localst) then
  3474. exit;
  3475. indexnr:=tloadnode(n).symtableentry.owner.SymList.IndexOf(tloadnode(n).symtableentry);
  3476. if (indexnr >= inlinelocals.count) or
  3477. not assigned(inlinelocals[indexnr]) then
  3478. internalerror(20040720);
  3479. temp := tnode(inlinelocals[indexnr]).getcopy;
  3480. { inherit modification information, this is needed by the dfa/cse }
  3481. temp.flags:=temp.flags+(n.flags*[nf_modify,nf_write,nf_address_taken]);
  3482. n.free;
  3483. n:=temp;
  3484. typecheckpass(n);
  3485. result := fen_true;
  3486. end;
  3487. end;
  3488. end;
  3489. end;
  3490. procedure tcallnode.createlocaltemps(p:TObject;arg:pointer);
  3491. var
  3492. tempnode: ttempcreatenode;
  3493. indexnr : integer;
  3494. begin
  3495. if (TSym(p).typ <> localvarsym) then
  3496. exit;
  3497. indexnr:=TSym(p).Owner.SymList.IndexOf(p);
  3498. if (indexnr >= inlinelocals.count) then
  3499. inlinelocals.count:=indexnr+10;
  3500. if (vo_is_funcret in tabstractvarsym(p).varoptions) then
  3501. begin
  3502. if not assigned(funcretnode) then
  3503. internalerror(200709081);
  3504. inlinelocals[indexnr] := funcretnode.getcopy
  3505. end
  3506. else
  3507. begin
  3508. tempnode :=ctempcreatenode.create(tabstractvarsym(p).vardef,
  3509. tabstractvarsym(p).vardef.size,tt_persistent,tabstractvarsym(p).is_regvar(false));
  3510. addstatement(inlineinitstatement,tempnode);
  3511. if localvartrashing <> -1 then
  3512. cnodeutils.maybe_trash_variable(inlineinitstatement,tabstractnormalvarsym(p),ctemprefnode.create(tempnode));
  3513. addstatement(inlinecleanupstatement,ctempdeletenode.create(tempnode));
  3514. { inherit addr_taken flag }
  3515. if (tabstractvarsym(p).addr_taken) then
  3516. include(tempnode.tempinfo^.flags,ti_addr_taken);
  3517. inlinelocals[indexnr] := ctemprefnode.create(tempnode);
  3518. end;
  3519. end;
  3520. function nonlocalvars(var n: tnode; arg: pointer): foreachnoderesult;
  3521. begin
  3522. result := fen_false;
  3523. { this is just to play it safe, there are more safe situations }
  3524. if (n.nodetype = derefn) or
  3525. ((n.nodetype = loadn) and
  3526. { globals and fields of (possibly global) objects could always be changed in the callee }
  3527. ((tloadnode(n).symtable.symtabletype in [globalsymtable,ObjectSymtable]) or
  3528. { statics can only be modified by functions in the same unit }
  3529. ((tloadnode(n).symtable.symtabletype = staticsymtable) and
  3530. (tloadnode(n).symtable = TSymtable(arg))))) or
  3531. ((n.nodetype = subscriptn) and
  3532. (tsubscriptnode(n).vs.owner.symtabletype = ObjectSymtable)) then
  3533. result := fen_norecurse_true;
  3534. end;
  3535. procedure tcallnode.createinlineparas;
  3536. var
  3537. para: tcallparanode;
  3538. tempnode: ttempcreatenode;
  3539. n: tnode;
  3540. paracomplexity: longint;
  3541. pushconstaddr: boolean;
  3542. trytotakeaddress : Boolean;
  3543. begin
  3544. { parameters }
  3545. para := tcallparanode(left);
  3546. pushconstaddr := false;
  3547. while assigned(para) do
  3548. begin
  3549. if (para.parasym.typ = paravarsym) and
  3550. ((para.parasym.refs>0) or
  3551. not(cs_opt_dead_values in current_settings.optimizerswitches) or
  3552. might_have_sideeffects(para.left)) then
  3553. begin
  3554. { must take copy of para.left, because if it contains a }
  3555. { temprefn pointing to a copied temp (e.g. methodpointer), }
  3556. { then this parameter must be changed to point to the copy of }
  3557. { that temp (JM) }
  3558. n := para.left.getcopy;
  3559. para.left.free;
  3560. para.left := n;
  3561. firstpass(para.left);
  3562. { determine how a parameter is passed to the inlined body
  3563. There are three options:
  3564. - insert the node tree of the callparanode directly
  3565. If a parameter is used only once, this is the best option if we can do so
  3566. - get the address of the argument, store it in a temp and insert a dereference to this temp
  3567. If the node tree cannot be inserted directly, taking the address of the argument and using it
  3568. is the second best option, but even this is not always possible
  3569. - assign the value of the argument to a newly created temp
  3570. This is the fall back which works always
  3571. Notes:
  3572. - we need to take care that we use the type of the defined parameter and not of the
  3573. passed parameter, because these can be different in case of a formaldef (PFV)
  3574. }
  3575. { pre-compute some values }
  3576. paracomplexity:=node_complexity(para.left);
  3577. if para.parasym.varspez=vs_const then
  3578. pushconstaddr:=paramanager.push_addr_param(vs_const,para.parasym.vardef,procdefinition.proccalloption);
  3579. { if the parameter is "complex", try to take the address
  3580. of the parameter expression, store it in a temp and replace
  3581. occurrences of the parameter with dereferencings of this
  3582. temp
  3583. }
  3584. trytotakeaddress:=
  3585. { don't create a temp. for function results }
  3586. not(nf_is_funcret in para.left.flags) and
  3587. { this makes only sense if the parameter is reasonable complex else inserting directly is a better solution }
  3588. ((paracomplexity>2) or
  3589. { don't create a temp. for the often seen case that p^ is passed to a var parameter }
  3590. ((paracomplexity>1) and not((para.left.nodetype=derefn) and (para.parasym.varspez = vs_var))));
  3591. { check if we have to create a temp, assign the parameter's
  3592. contents to that temp and then substitute the parameter
  3593. with the temp everywhere in the function }
  3594. if
  3595. ((tparavarsym(para.parasym).varregable in [vr_none,vr_addr]) and
  3596. not(para.left.expectloc in [LOC_REFERENCE,LOC_CREFERENCE])) or
  3597. { we can't assign to formaldef temps }
  3598. ((para.parasym.vardef.typ<>formaldef) and
  3599. (
  3600. { can we take the address of the argument? }
  3601. (trytotakeaddress and not(para.left.expectloc in [LOC_REFERENCE,LOC_CREFERENCE])) or
  3602. (trytotakeaddress and
  3603. (not valid_for_addr(para.left,false) or
  3604. (para.left.nodetype = calln) or
  3605. is_constnode(para.left))) or
  3606. { we do not need to create a temp for value parameters }
  3607. { which are not modified in the inlined function }
  3608. { const parameters can get vs_readwritten if their }
  3609. { address is taken }
  3610. ((((para.parasym.varspez = vs_value) and
  3611. (para.parasym.varstate in [vs_initialised,vs_declared,vs_read])) or
  3612. { in case of const, this is only necessary if the
  3613. variable would be passed by value normally and if it is modified or if
  3614. there is such a variable somewhere in an expression }
  3615. ((para.parasym.varspez = vs_const) and
  3616. (not pushconstaddr))) and
  3617. { however, if we pass a global variable, an object field or}
  3618. { an expression containing a pointer dereference as }
  3619. { parameter, this value could be modified in other ways as }
  3620. { well and in such cases create a temp to be on the safe }
  3621. { side }
  3622. foreachnodestatic(para.left,@nonlocalvars,pointer(symtableproc))) or
  3623. { value parameters of which we know they are modified by }
  3624. { definition have to be copied to a temp }
  3625. { the same goes for cases of "x:=f(x)" where x is passed }
  3626. { as value parameter to f(), at least if we optimized }
  3627. { invocation by setting the funcretnode to x to avoid }
  3628. { assignment afterwards (since x may be read inside the }
  3629. { function after it modified result==x) }
  3630. ((para.parasym.varspez = vs_value) and
  3631. (not(para.parasym.varstate in [vs_initialised,vs_declared,vs_read]) or
  3632. (assigned(aktassignmentnode) and
  3633. (aktassignmentnode.right=self) and
  3634. (nf_assign_done_in_right in aktassignmentnode.flags) and
  3635. aktassignmentnode.left.isequal(para.left)))) or
  3636. { the compiler expects that it can take the address of parameters passed by reference in
  3637. the case of const so we can't replace the node simply by a constant node
  3638. When playing with this code, ensure that
  3639. function f(const a,b : longint) : longint;inline;
  3640. begin
  3641. result:=a*b;
  3642. end;
  3643. [...]
  3644. ...:=f(10,20));
  3645. [...]
  3646. is still folded. (FK)
  3647. }
  3648. ((para.parasym.varspez = vs_const) and
  3649. { const para's can get vs_readwritten if their address }
  3650. { is taken -> in case they are not passed by reference, }
  3651. { to keep the same behaviour as without inlining we have }
  3652. { to make a copy in case the originally passed parameter }
  3653. { value gets changed inside the callee }
  3654. ((not pushconstaddr and
  3655. (para.parasym.varstate = vs_readwritten)
  3656. ) or
  3657. { call-by-reference const's may need to be passed by }
  3658. { reference to function called in the inlined code }
  3659. (pushconstaddr and
  3660. not valid_for_addr(para.left,false))
  3661. )
  3662. )
  3663. )
  3664. ) then
  3665. begin
  3666. { don't create a new temp unnecessarily, but make sure we
  3667. do create a new one if the old one could be a regvar and
  3668. the new one cannot be one }
  3669. if not(tparavarsym(para.parasym).varspez in [vs_out,vs_var]) and (((para.left.nodetype<>temprefn) or
  3670. (((tparavarsym(para.parasym).varregable in [vr_none,vr_addr])) and
  3671. (ti_may_be_in_reg in ttemprefnode(para.left).tempinfo^.flags)))) then
  3672. begin
  3673. tempnode := ctempcreatenode.create(para.parasym.vardef,para.parasym.vardef.size,
  3674. tt_persistent,tparavarsym(para.parasym).is_regvar(false));
  3675. addstatement(inlineinitstatement,tempnode);
  3676. if localvartrashing <> -1 then
  3677. cnodeutils.maybe_trash_variable(inlineinitstatement,para.parasym,ctemprefnode.create(tempnode));
  3678. addstatement(inlinecleanupstatement,ctempdeletenode.create(tempnode));
  3679. addstatement(inlineinitstatement,cassignmentnode.create(ctemprefnode.create(tempnode),
  3680. para.left));
  3681. para.left := ctemprefnode.create(tempnode);
  3682. { inherit addr_taken flag }
  3683. if (tabstractvarsym(para.parasym).addr_taken) then
  3684. include(tempnode.tempinfo^.flags,ti_addr_taken);
  3685. end;
  3686. end
  3687. else if trytotakeaddress then
  3688. wrapcomplexinlinepara(para);
  3689. end;
  3690. para := tcallparanode(para.right);
  3691. end;
  3692. { local variables }
  3693. if not assigned(tprocdef(procdefinition).localst) or
  3694. (tprocdef(procdefinition).localst.SymList.count = 0) then
  3695. exit;
  3696. inlinelocals.count:=tprocdef(procdefinition).localst.SymList.count;
  3697. tprocdef(procdefinition).localst.SymList.ForEachCall(@createlocaltemps,nil);
  3698. end;
  3699. procedure tcallnode.wrapcomplexinlinepara(para: tcallparanode);
  3700. var
  3701. ptrtype: tdef;
  3702. tempnode: ttempcreatenode;
  3703. paraaddr: taddrnode;
  3704. begin
  3705. ptrtype:=getpointerdef(para.left.resultdef);
  3706. tempnode:=ctempcreatenode.create(ptrtype,ptrtype.size,tt_persistent,true);
  3707. addstatement(inlineinitstatement,tempnode);
  3708. addstatement(inlinecleanupstatement,ctempdeletenode.create(tempnode));
  3709. { inherit addr_taken flag }
  3710. if (tabstractvarsym(para.parasym).addr_taken) then
  3711. include(tempnode.tempinfo^.flags,ti_addr_taken);
  3712. { inherit read only }
  3713. if tabstractvarsym(para.parasym).varspez=vs_const then
  3714. include(tempnode.tempinfo^.flags,ti_const);
  3715. paraaddr:=caddrnode.create_internal(para.left);
  3716. include(paraaddr.flags,nf_typedaddr);
  3717. addstatement(inlineinitstatement,cassignmentnode.create(ctemprefnode.create(tempnode),
  3718. paraaddr));
  3719. para.left:=cderefnode.create(ctemprefnode.create(tempnode));
  3720. end;
  3721. function tcallnode.optimize_funcret_assignment(inlineblock: tblocknode): tnode;
  3722. var
  3723. hp : tstatementnode;
  3724. hp2 : tnode;
  3725. resassign : tassignmentnode;
  3726. begin
  3727. result:=nil;
  3728. if not assigned(funcretnode) or
  3729. not(cnf_return_value_used in callnodeflags) then
  3730. exit;
  3731. { tempcreatenode for the function result }
  3732. hp:=tstatementnode(inlineblock.left);
  3733. if not(assigned(hp)) or
  3734. (hp.left.nodetype <> tempcreaten) or
  3735. not(nf_is_funcret in hp.left.flags) then
  3736. exit;
  3737. { constant assignment? right must be a constant (mainly to avoid trying
  3738. to reuse local temps which may already be freed afterwards once these
  3739. checks are made looser) }
  3740. hp:=tstatementnode(hp.right);
  3741. if not(assigned(hp)) or
  3742. (hp.left.nodetype<>assignn) or
  3743. not is_constnode(tassignmentnode(hp.left).right) then
  3744. exit;
  3745. { left must be function result }
  3746. resassign:=tassignmentnode(hp.left);
  3747. hp2:=resassign.left;
  3748. { can have extra type conversion due to absolute mapping
  3749. of <fucntionname> on function result var }
  3750. if (hp2.nodetype=typeconvn) and (ttypeconvnode(hp2).convtype=tc_equal) then
  3751. hp2:=ttypeconvnode(hp2).left;
  3752. if (hp2.nodetype<>temprefn) or
  3753. not(nf_is_funcret in hp2.flags) then
  3754. exit;
  3755. { tempdelete to normal of the function result }
  3756. hp:=tstatementnode(hp.right);
  3757. if not(assigned(hp)) or
  3758. (hp.left.nodetype <> tempdeleten) then
  3759. exit;
  3760. { the function result once more }
  3761. hp:=tstatementnode(hp.right);
  3762. if not(assigned(hp)) or
  3763. (hp.left.nodetype<>temprefn) or
  3764. not(nf_is_funcret in hp.left.flags) then
  3765. exit;
  3766. { should be the end }
  3767. if assigned(hp.right) then
  3768. exit;
  3769. { we made it! }
  3770. result:=tassignmentnode(resassign).right.getcopy;
  3771. firstpass(result);
  3772. end;
  3773. function tcallnode.pass1_inline:tnode;
  3774. var
  3775. n,
  3776. body : tnode;
  3777. para : tcallparanode;
  3778. inlineblock,
  3779. inlinecleanupblock : tblocknode;
  3780. begin
  3781. result:=nil;
  3782. if not(assigned(tprocdef(procdefinition).inlininginfo) and
  3783. assigned(tprocdef(procdefinition).inlininginfo^.code)) then
  3784. internalerror(200412021);
  3785. inlinelocals:=TFPObjectList.create(true);
  3786. { inherit flags }
  3787. current_procinfo.flags:=current_procinfo.flags+
  3788. ((procdefinition as tprocdef).inlininginfo^.flags*inherited_inlining_flags);
  3789. { Create new code block for inlining }
  3790. inlineblock:=internalstatements(inlineinitstatement);
  3791. { make sure that valid_for_assign() returns false for this block
  3792. (otherwise assigning values to the block will result in assigning
  3793. values to the inlined function's result) }
  3794. include(inlineblock.flags,nf_no_lvalue);
  3795. inlinecleanupblock:=internalstatements(inlinecleanupstatement);
  3796. if assigned(callinitblock) then
  3797. addstatement(inlineinitstatement,callinitblock.getcopy);
  3798. { replace complex parameters with temps }
  3799. createinlineparas;
  3800. { create a copy of the body and replace parameter loads with the parameter values }
  3801. body:=tprocdef(procdefinition).inlininginfo^.code.getcopy;
  3802. foreachnode(pm_preprocess,body,@replaceparaload,@fileinfo);
  3803. { Concat the body and finalization parts }
  3804. addstatement(inlineinitstatement,body);
  3805. addstatement(inlineinitstatement,inlinecleanupblock);
  3806. inlinecleanupblock:=nil;
  3807. if assigned(callcleanupblock) then
  3808. addstatement(inlineinitstatement,callcleanupblock.getcopy);
  3809. { the last statement of the new inline block must return the
  3810. location and type of the function result.
  3811. This is not needed when the result is not used, also the tempnode is then
  3812. already destroyed by a tempdelete in the callcleanupblock tree }
  3813. if not is_void(resultdef) and
  3814. (cnf_return_value_used in callnodeflags) then
  3815. begin
  3816. if assigned(funcretnode) then
  3817. addstatement(inlineinitstatement,funcretnode.getcopy)
  3818. else
  3819. begin
  3820. para:=tcallparanode(left);
  3821. while assigned(para) do
  3822. begin
  3823. if (vo_is_hidden_para in para.parasym.varoptions) and
  3824. (vo_is_funcret in para.parasym.varoptions) then
  3825. begin
  3826. addstatement(inlineinitstatement,para.left.getcopy);
  3827. break;
  3828. end;
  3829. para:=tcallparanode(para.right);
  3830. end;
  3831. end;
  3832. end;
  3833. { consider it must not be inlined if called
  3834. again inside the args or itself }
  3835. exclude(procdefinition.procoptions,po_inline);
  3836. typecheckpass(tnode(inlineblock));
  3837. doinlinesimplify(tnode(inlineblock));
  3838. firstpass(tnode(inlineblock));
  3839. include(procdefinition.procoptions,po_inline);
  3840. result:=inlineblock;
  3841. { if the function result is used then verify that the blocknode
  3842. returns the same result type as the original callnode }
  3843. if (cnf_return_value_used in callnodeflags) and
  3844. (result.resultdef<>resultdef) then
  3845. internalerror(200709171);
  3846. { free the temps for the locals }
  3847. inlinelocals.free;
  3848. inlinelocals:=nil;
  3849. inlineinitstatement:=nil;
  3850. inlinecleanupstatement:=nil;
  3851. { if all that's left of the inlined function is an constant assignment
  3852. to the result, replace the whole block with the constant only }
  3853. n:=optimize_funcret_assignment(inlineblock);
  3854. if assigned(n) then
  3855. begin
  3856. inlineblock.free;
  3857. result:=n;
  3858. end;
  3859. {$ifdef DEBUGINLINE}
  3860. writeln;
  3861. writeln('**************************',tprocdef(procdefinition).mangledname);
  3862. printnode(output,result);
  3863. {$endif DEBUGINLINE}
  3864. end;
  3865. end.