2
0

ncal.pas 149 KB

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