ncal.pas 161 KB

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