ncal.pas 67 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704
  1. {
  2. $Id$
  3. Copyright (c) 1998-2000 by Florian Klaempfl
  4. This file implements the node for sub procedure calling
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit ncal;
  19. {$i defines.inc}
  20. interface
  21. uses
  22. node,
  23. symbase,symsym,symdef,symtable;
  24. type
  25. tcallnode = class(tbinarynode)
  26. { the symbol containing the definition of the procedure }
  27. { to call }
  28. symtableprocentry : pprocsym;
  29. { the symtable containing symtableprocentry }
  30. symtableproc : psymtable;
  31. { the definition of the procedure to call }
  32. procdefinition : pabstractprocdef;
  33. methodpointer : tnode;
  34. { only the processor specific nodes need to override this }
  35. { constructor }
  36. constructor create(l:tnode; v : pprocsym;st : psymtable; mp : tnode);virtual;
  37. destructor destroy;override;
  38. function getcopy : tnode;override;
  39. procedure insertintolist(l : tnodelist);override;
  40. function pass_1 : tnode;override;
  41. function det_resulttype:tnode;override;
  42. function docompare(p: tnode): boolean; override;
  43. procedure set_procvar(procvar:tnode);
  44. end;
  45. tcallparaflags = (
  46. { flags used by tcallparanode }
  47. cpf_exact_match_found,
  48. cpf_convlevel1found,
  49. cpf_convlevel2found,
  50. cpf_is_colon_para
  51. );
  52. tcallparanode = class(tbinarynode)
  53. callparaflags : set of tcallparaflags;
  54. hightree : tnode;
  55. { only the processor specific nodes need to override this }
  56. { constructor }
  57. constructor create(expr,next : tnode);virtual;
  58. destructor destroy;override;
  59. function getcopy : tnode;override;
  60. procedure insertintolist(l : tnodelist);override;
  61. procedure gen_high_tree(openstring:boolean);
  62. procedure get_paratype;
  63. procedure insert_typeconv(defcoll : tparaitem;do_count : boolean);
  64. procedure det_registers;
  65. procedure firstcallparan(defcoll : tparaitem;do_count : boolean);
  66. procedure secondcallparan(defcoll : tparaitem;
  67. push_from_left_to_right,inlined,is_cdecl : boolean;
  68. para_alignment,para_offset : longint);virtual;abstract;
  69. function docompare(p: tnode): boolean; override;
  70. end;
  71. tprocinlinenode = class(tnode)
  72. inlinetree : tnode;
  73. inlineprocsym : pprocsym;
  74. retoffset,para_offset,para_size : longint;
  75. constructor create(callp,code : tnode);virtual;
  76. destructor destroy;override;
  77. function getcopy : tnode;override;
  78. procedure insertintolist(l : tnodelist);override;
  79. function pass_1 : tnode;override;
  80. function docompare(p: tnode): boolean; override;
  81. end;
  82. var
  83. ccallnode : class of tcallnode;
  84. ccallparanode : class of tcallparanode;
  85. cprocinlinenode : class of tprocinlinenode;
  86. implementation
  87. uses
  88. cutils,globtype,systems,
  89. verbose,globals,
  90. symconst,symtype,types,
  91. htypechk,pass_1,cpubase,
  92. ncnv,nld,ninl,nadd,ncon,hcodegen,
  93. tgcpu
  94. {$ifdef newcg}
  95. ,cgbase
  96. {$endif newcg}
  97. ;
  98. {****************************************************************************
  99. TCALLPARANODE
  100. ****************************************************************************}
  101. constructor tcallparanode.create(expr,next : tnode);
  102. begin
  103. inherited create(callparan,expr,next);
  104. hightree:=nil;
  105. if assigned(expr) then
  106. expr.set_file_line(self);
  107. callparaflags:=[];
  108. end;
  109. destructor tcallparanode.destroy;
  110. begin
  111. hightree.free;
  112. inherited destroy;
  113. end;
  114. function tcallparanode.getcopy : tnode;
  115. var
  116. n : tcallparanode;
  117. begin
  118. n:=tcallparanode(inherited getcopy);
  119. n.callparaflags:=callparaflags;
  120. if assigned(hightree) then
  121. n.hightree:=hightree.getcopy
  122. else
  123. n.hightree:=nil;
  124. result:=n;
  125. end;
  126. procedure tcallparanode.insertintolist(l : tnodelist);
  127. begin
  128. end;
  129. procedure tcallparanode.get_paratype;
  130. var
  131. old_get_para_resulttype : boolean;
  132. old_array_constructor : boolean;
  133. begin
  134. inc(parsing_para_level);
  135. if assigned(right) then
  136. tcallparanode(right).get_paratype;
  137. old_array_constructor:=allow_array_constructor;
  138. old_get_para_resulttype:=get_para_resulttype;
  139. get_para_resulttype:=true;
  140. allow_array_constructor:=true;
  141. resulttypepass(left);
  142. get_para_resulttype:=old_get_para_resulttype;
  143. allow_array_constructor:=old_array_constructor;
  144. if codegenerror then
  145. resulttype:=generrortype
  146. else
  147. resulttype:=left.resulttype;
  148. dec(parsing_para_level);
  149. end;
  150. procedure tcallparanode.insert_typeconv(defcoll : tparaitem;do_count : boolean);
  151. var
  152. oldtype : ttype;
  153. {$ifdef extdebug}
  154. store_count_ref : boolean;
  155. {$endif def extdebug}
  156. begin
  157. inc(parsing_para_level);
  158. {$ifdef extdebug}
  159. if do_count then
  160. begin
  161. store_count_ref:=count_ref;
  162. count_ref:=true;
  163. end;
  164. {$endif def extdebug}
  165. if assigned(right) then
  166. begin
  167. if defcoll=nil then
  168. tcallparanode(right).insert_typeconv(nil,do_count)
  169. else
  170. tcallparanode(right).insert_typeconv(tparaitem(defcoll.next),do_count);
  171. end;
  172. { Be sure to have the resulttype }
  173. if not assigned(left.resulttype.def) then
  174. resulttypepass(left);
  175. { Do we need arrayconstructor -> set conversion, then insert
  176. it here before the arrayconstructor node breaks the tree
  177. with its conversions of enum->ord }
  178. if (left.nodetype=arrayconstructorn) and
  179. (defcoll.paratype.def^.deftype=setdef) then
  180. inserttypeconv(left,defcoll.paratype);
  181. { set some settings needed for arrayconstructor }
  182. if is_array_constructor(left.resulttype.def) then
  183. begin
  184. if is_array_of_const(defcoll.paratype.def) then
  185. begin
  186. if assigned(aktcallprocsym) and
  187. (([pocall_cppdecl,pocall_cdecl]*aktcallprocsym^.definition^.proccalloptions)<>[]) and
  188. (po_external in aktcallprocsym^.definition^.procoptions) then
  189. include(left.flags,nf_cargs);
  190. { force variant array }
  191. include(left.flags,nf_forcevaria);
  192. end
  193. else
  194. begin
  195. include(left.flags,nf_novariaallowed);
  196. tarrayconstructornode(left).constructortype:=parraydef(defcoll.paratype.def)^.elementtype;
  197. end;
  198. end;
  199. if do_count then
  200. begin
  201. { not completly proper, but avoids some warnings }
  202. if (defcoll.paratyp in [vs_var,vs_out]) then
  203. set_funcret_is_valid(left);
  204. { protected has nothing to do with read/write
  205. if (defcoll.paratyp in [vs_var,vs_out]) then
  206. test_protected(left);
  207. }
  208. { set_varstate(left,defcoll.paratyp<>vs_var);
  209. must only be done after typeconv PM }
  210. { only process typeconvn and arrayconstructn, else it will
  211. break other trees }
  212. { But this is need to get correct varstate !! PM }
  213. {old_array_constructor:=allow_array_constructor;
  214. old_get_para_resulttype:=get_para_resulttype;
  215. allow_array_constructor:=true;
  216. get_para_resulttype:=false;
  217. if (left.nodetype in [arrayconstructorn,typeconvn]) then
  218. firstpass(left);
  219. if not assigned(resulttype.def) then
  220. resulttype:=left.resulttype;
  221. get_para_resulttype:=old_get_para_resulttype;
  222. allow_array_constructor:=old_array_constructor; }
  223. end;
  224. { check if local proc/func is assigned to procvar }
  225. if left.resulttype.def^.deftype=procvardef then
  226. test_local_to_procvar(pprocvardef(left.resulttype.def),defcoll.paratype.def);
  227. { property is not allowed as var parameter }
  228. if (defcoll.paratyp in [vs_out,vs_var]) and
  229. (nf_isproperty in left.flags) then
  230. CGMessagePos(left.fileinfo,type_e_argument_cant_be_assigned);
  231. { generate the high() value tree }
  232. if not(assigned(aktcallprocsym) and
  233. (([pocall_cppdecl,pocall_cdecl]*aktcallprocsym^.definition^.proccalloptions)<>[]) and
  234. (po_external in aktcallprocsym^.definition^.procoptions)) and
  235. push_high_param(defcoll.paratype.def) then
  236. gen_high_tree(is_open_string(defcoll.paratype.def));
  237. if not(is_shortstring(left.resulttype.def) and
  238. is_shortstring(defcoll.paratype.def)) and
  239. (defcoll.paratype.def^.deftype<>formaldef) then
  240. begin
  241. if (defcoll.paratyp in [vs_var,vs_out]) and
  242. { allows conversion from word to integer and
  243. byte to shortint }
  244. (not(
  245. (left.resulttype.def^.deftype=orddef) and
  246. (defcoll.paratype.def^.deftype=orddef) and
  247. (left.resulttype.def^.size=defcoll.paratype.def^.size)
  248. ) and
  249. { an implicit pointer conversion is allowed }
  250. not(
  251. (left.resulttype.def^.deftype=pointerdef) and
  252. (defcoll.paratype.def^.deftype=pointerdef)
  253. ) and
  254. { child classes can be also passed }
  255. not(
  256. (left.resulttype.def^.deftype=objectdef) and
  257. (defcoll.paratype.def^.deftype=objectdef) and
  258. pobjectdef(left.resulttype.def)^.is_related(pobjectdef(defcoll.paratype.def))
  259. ) and
  260. { passing a single element to a openarray of the same type }
  261. not(
  262. (is_open_array(defcoll.paratype.def) and
  263. is_equal(parraydef(defcoll.paratype.def)^.elementtype.def,left.resulttype.def))
  264. ) and
  265. { an implicit file conversion is also allowed }
  266. { from a typed file to an untyped one }
  267. not(
  268. (left.resulttype.def^.deftype=filedef) and
  269. (defcoll.paratype.def^.deftype=filedef) and
  270. (pfiledef(defcoll.paratype.def)^.filetyp = ft_untyped) and
  271. (pfiledef(left.resulttype.def)^.filetyp = ft_typed)
  272. ) and
  273. not(is_equal(left.resulttype.def,defcoll.paratype.def))) then
  274. begin
  275. CGMessagePos2(left.fileinfo,parser_e_call_by_ref_without_typeconv,
  276. left.resulttype.def^.typename,defcoll.paratype.def^.typename);
  277. end;
  278. { Process open parameters }
  279. if push_high_param(defcoll.paratype.def) then
  280. begin
  281. { insert type conv but hold the ranges of the array }
  282. oldtype:=left.resulttype;
  283. inserttypeconv(left,defcoll.paratype);
  284. left.resulttype:=oldtype;
  285. end
  286. else
  287. begin
  288. inserttypeconv(left,defcoll.paratype);
  289. end;
  290. if codegenerror then
  291. begin
  292. dec(parsing_para_level);
  293. exit;
  294. end;
  295. end;
  296. { check var strings }
  297. if (cs_strict_var_strings in aktlocalswitches) and
  298. is_shortstring(left.resulttype.def) and
  299. is_shortstring(defcoll.paratype.def) and
  300. (defcoll.paratyp in [vs_out,vs_var]) and
  301. not(is_open_string(defcoll.paratype.def)) and
  302. not(is_equal(left.resulttype.def,defcoll.paratype.def)) then
  303. begin
  304. aktfilepos:=left.fileinfo;
  305. CGMessage(type_e_strict_var_string_violation);
  306. end;
  307. { variabls for call by reference may not be copied }
  308. { into a register }
  309. { is this usefull here ? }
  310. { this was missing in formal parameter list }
  311. if (defcoll.paratype.def^.deftype=formaldef) then
  312. begin
  313. if defcoll.paratyp in [vs_var,vs_out] then
  314. begin
  315. if not valid_for_formal_var(left) then
  316. begin
  317. aktfilepos:=left.fileinfo;
  318. CGMessage(parser_e_illegal_parameter_list);
  319. end;
  320. end;
  321. if defcoll.paratyp=vs_const then
  322. begin
  323. if not valid_for_formal_const(left) then
  324. begin
  325. aktfilepos:=left.fileinfo;
  326. CGMessage(parser_e_illegal_parameter_list);
  327. end;
  328. end;
  329. end;
  330. if defcoll.paratyp in [vs_var,vs_const] then
  331. begin
  332. { Causes problems with const ansistrings if also }
  333. { done for vs_const (JM) }
  334. if defcoll.paratyp = vs_var then
  335. set_unique(left);
  336. make_not_regable(left);
  337. end;
  338. { ansistrings out paramaters doesn't need to be }
  339. { unique, they are finalized }
  340. if defcoll.paratyp=vs_out then
  341. make_not_regable(left);
  342. if do_count then
  343. set_varstate(left,not(defcoll.paratyp in [vs_var,vs_out]));
  344. { must only be done after typeconv PM }
  345. resulttype:=defcoll.paratype;
  346. dec(parsing_para_level);
  347. {$ifdef extdebug}
  348. if do_count then
  349. count_ref:=store_count_ref;
  350. {$endif def extdebug}
  351. end;
  352. procedure tcallparanode.det_registers;
  353. var
  354. old_get_para_resulttype : boolean;
  355. old_array_constructor : boolean;
  356. begin
  357. if assigned(right) then
  358. begin
  359. tcallparanode(right).det_registers;
  360. registers32:=right.registers32;
  361. registersfpu:=right.registersfpu;
  362. {$ifdef SUPPORT_MMX}
  363. registersmmx:=right.registersmmx;
  364. {$endif}
  365. end;
  366. old_array_constructor:=allow_array_constructor;
  367. old_get_para_resulttype:=get_para_resulttype;
  368. get_para_resulttype:=true;
  369. allow_array_constructor:=true;
  370. firstpass(left);
  371. get_para_resulttype:=old_get_para_resulttype;
  372. allow_array_constructor:=old_array_constructor;
  373. if left.registers32>registers32 then
  374. registers32:=left.registers32;
  375. if left.registersfpu>registersfpu then
  376. registersfpu:=left.registersfpu;
  377. {$ifdef SUPPORT_MMX}
  378. if left.registersmmx>registersmmx then
  379. registersmmx:=left.registersmmx;
  380. {$endif SUPPORT_MMX}
  381. end;
  382. procedure tcallparanode.firstcallparan(defcoll : tparaitem;do_count : boolean);
  383. begin
  384. if not assigned(left.resulttype.def) then
  385. begin
  386. get_paratype;
  387. if assigned(defcoll) then
  388. insert_typeconv(defcoll,do_count);
  389. end;
  390. det_registers;
  391. end;
  392. procedure tcallparanode.gen_high_tree(openstring:boolean);
  393. var
  394. len : longint;
  395. st : psymtable;
  396. loadconst : boolean;
  397. srsym : psym;
  398. begin
  399. if assigned(hightree) then
  400. exit;
  401. len:=-1;
  402. loadconst:=true;
  403. case left.resulttype.def^.deftype of
  404. arraydef :
  405. begin
  406. if is_open_array(left.resulttype.def) or
  407. is_array_of_const(left.resulttype.def) then
  408. begin
  409. st:=tloadnode(left).symtable;
  410. srsym:=searchsymonlyin(st,'high'+pvarsym(tloadnode(left).symtableentry)^.name);
  411. hightree:=cloadnode.create(pvarsym(srsym),st);
  412. loadconst:=false;
  413. end
  414. else
  415. begin
  416. { this is an empty constructor }
  417. len:=parraydef(left.resulttype.def)^.highrange-
  418. parraydef(left.resulttype.def)^.lowrange;
  419. end;
  420. end;
  421. stringdef :
  422. begin
  423. if openstring then
  424. begin
  425. if is_open_string(left.resulttype.def) then
  426. begin
  427. st:=tloadnode(left).symtable;
  428. srsym:=searchsymonlyin(st,'high'+pvarsym(tloadnode(left).symtableentry)^.name);
  429. hightree:=cloadnode.create(pvarsym(srsym),st);
  430. loadconst:=false;
  431. end
  432. else
  433. len:=pstringdef(left.resulttype.def)^.len;
  434. end
  435. else
  436. { passing a string to an array of char }
  437. begin
  438. if (left.nodetype=stringconstn) then
  439. begin
  440. len:=str_length(left);
  441. if len>0 then
  442. dec(len);
  443. end
  444. else
  445. begin
  446. hightree:=caddnode.create(subn,geninlinenode(in_length_string,false,left.getcopy),
  447. cordconstnode.create(1,s32bittype));
  448. firstpass(hightree);
  449. hightree:=ctypeconvnode.create(hightree,s32bittype);
  450. loadconst:=false;
  451. end;
  452. end;
  453. end;
  454. else
  455. len:=0;
  456. end;
  457. if loadconst then
  458. hightree:=cordconstnode.create(len,s32bittype);
  459. firstpass(hightree);
  460. end;
  461. function tcallparanode.docompare(p: tnode): boolean;
  462. begin
  463. docompare :=
  464. inherited docompare(p) and
  465. (callparaflags = tcallparanode(p).callparaflags) and
  466. hightree.isequal(tcallparanode(p).hightree);
  467. end;
  468. {****************************************************************************
  469. TCALLNODE
  470. ****************************************************************************}
  471. constructor tcallnode.create(l:tnode;v : pprocsym;st : psymtable; mp : tnode);
  472. begin
  473. inherited create(calln,l,nil);
  474. symtableprocentry:=v;
  475. symtableproc:=st;
  476. include(flags,nf_return_value_used);
  477. methodpointer:=mp;
  478. procdefinition:=nil;
  479. end;
  480. destructor tcallnode.destroy;
  481. begin
  482. methodpointer.free;
  483. inherited destroy;
  484. end;
  485. procedure tcallnode.set_procvar(procvar:tnode);
  486. begin
  487. right:=procvar;
  488. end;
  489. function tcallnode.getcopy : tnode;
  490. var
  491. n : tcallnode;
  492. begin
  493. n:=tcallnode(inherited getcopy);
  494. n.symtableprocentry:=symtableprocentry;
  495. n.symtableproc:=symtableproc;
  496. n.procdefinition:=procdefinition;
  497. if assigned(methodpointer) then
  498. n.methodpointer:=methodpointer.getcopy
  499. else
  500. n.methodpointer:=nil;
  501. result:=n;
  502. end;
  503. procedure tcallnode.insertintolist(l : tnodelist);
  504. begin
  505. end;
  506. function tcallnode.det_resulttype:tnode;
  507. type
  508. pprocdefcoll = ^tprocdefcoll;
  509. tprocdefcoll = record
  510. data : pprocdef;
  511. nextpara : tparaitem;
  512. firstpara : tparaitem;
  513. next : pprocdefcoll;
  514. end;
  515. var
  516. hp,procs,hp2 : pprocdefcoll;
  517. pd : pprocdef;
  518. oldcallprocsym : pprocsym;
  519. def_from,def_to,conv_to : pdef;
  520. hpt,hpt2 : tnode;
  521. pt : tcallparanode;
  522. exactmatch : boolean;
  523. paralength,lastpara : longint;
  524. lastparatype : pdef;
  525. pdc : tparaitem;
  526. {$ifdef TEST_PROCSYMS}
  527. nextprocsym : pprocsym;
  528. symt : psymtable;
  529. {$endif TEST_PROCSYMS}
  530. { only Dummy }
  531. hcvt : tconverttype;
  532. label
  533. errorexit;
  534. { check if the resulttype.def from tree p is equal with def, needed
  535. for stringconstn and formaldef }
  536. function is_equal(p:tcallparanode;def:pdef) : boolean;
  537. begin
  538. { safety check }
  539. if not (assigned(def) or assigned(p.resulttype.def)) then
  540. begin
  541. is_equal:=false;
  542. exit;
  543. end;
  544. { all types can be passed to a formaldef }
  545. is_equal:=(def^.deftype=formaldef) or
  546. (types.is_equal(p.resulttype.def,def))
  547. { integer constants are compatible with all integer parameters if
  548. the specified value matches the range }
  549. or
  550. (
  551. (tbinarynode(p).left.nodetype=ordconstn) and
  552. is_integer(p.resulttype.def) and
  553. is_integer(def) and
  554. (tordconstnode(p.left).value>=porddef(def)^.low) and
  555. (tordconstnode(p.left).value<=porddef(def)^.high)
  556. )
  557. { to support ansi/long/wide strings in a proper way }
  558. { string and string[10] are assumed as equal }
  559. { when searching the correct overloaded procedure }
  560. or
  561. (
  562. (def^.deftype=stringdef) and (p.resulttype.def^.deftype=stringdef) and
  563. (pstringdef(def)^.string_typ=pstringdef(p.resulttype.def)^.string_typ)
  564. )
  565. or
  566. (
  567. (p.left.nodetype=stringconstn) and
  568. (is_ansistring(p.resulttype.def) and is_pchar(def))
  569. )
  570. or
  571. (
  572. (p.left.nodetype=ordconstn) and
  573. (is_char(p.resulttype.def) and (is_shortstring(def) or is_ansistring(def)))
  574. )
  575. { set can also be a not yet converted array constructor }
  576. or
  577. (
  578. (def^.deftype=setdef) and (p.resulttype.def^.deftype=arraydef) and
  579. (parraydef(p.resulttype.def)^.IsConstructor) and not(parraydef(p.resulttype.def)^.IsVariant)
  580. )
  581. { in tp7 mode proc -> procvar is allowed }
  582. or
  583. (
  584. (m_tp_procvar in aktmodeswitches) and
  585. (def^.deftype=procvardef) and (p.left.nodetype=calln) and
  586. (proc_to_procvar_equal(pprocdef(tcallnode(p.left).procdefinition),pprocvardef(def)))
  587. )
  588. ;
  589. end;
  590. function is_in_limit(def_from,def_to : pdef) : boolean;
  591. begin
  592. is_in_limit:=(def_from^.deftype = orddef) and
  593. (def_to^.deftype = orddef) and
  594. (porddef(def_from)^.low>porddef(def_to)^.low) and
  595. (porddef(def_from)^.high<porddef(def_to)^.high);
  596. end;
  597. var
  598. i : longint;
  599. is_const : boolean;
  600. bestord : porddef;
  601. begin
  602. result:=nil;
  603. procs:=nil;
  604. oldcallprocsym:=aktcallprocsym;
  605. aktcallprocsym:=nil;
  606. { procedure variable ? }
  607. if assigned(right) then
  608. begin
  609. resulttypepass(right);
  610. if codegenerror then
  611. exit;
  612. { check the parameters }
  613. pdc:=tparaitem(pprocvardef(right.resulttype.def)^.Para.first);
  614. pt:=tcallparanode(left);
  615. while assigned(pdc) and assigned(pt) do
  616. begin
  617. pt:=tcallparanode(pt.right);
  618. pdc:=tparaitem(pdc.next);
  619. end;
  620. if assigned(pt) or assigned(pdc) then
  621. begin
  622. if assigned(pt) then
  623. aktfilepos:=pt.fileinfo;
  624. CGMessage(parser_e_illegal_parameter_list);
  625. end;
  626. procdefinition:=pabstractprocdef(right.resulttype.def);
  627. end
  628. else
  629. { not a procedure variable }
  630. begin
  631. { determine the type of the parameters }
  632. if assigned(left) then
  633. begin
  634. tcallparanode(left).get_paratype;
  635. if codegenerror then
  636. goto errorexit;
  637. end;
  638. aktcallprocsym:=pprocsym(symtableprocentry);
  639. { do we know the procedure to call ? }
  640. if not(assigned(procdefinition)) then
  641. begin
  642. {$ifdef TEST_PROCSYMS}
  643. if (unit_specific) or
  644. assigned(methodpointer) then
  645. nextprocsym:=nil
  646. else while not assigned(procs) do
  647. begin
  648. symt:=symtableproc;
  649. srsym:=nil;
  650. while assigned(symt^.next) and not assigned(srsym) do
  651. begin
  652. symt:=symt^.next;
  653. srsym:=searchsymonlyin(symt,actprocsym^.name);
  654. if assigned(srsym) then
  655. if srsym^.typ<>procsym then
  656. begin
  657. { reject all that is not a procedure }
  658. srsym:=nil;
  659. { don't search elsewhere }
  660. while assigned(symt^.next) do
  661. symt:=symt^.next;
  662. end;
  663. end;
  664. nextprocsym:=srsym;
  665. end;
  666. {$endif TEST_PROCSYMS}
  667. { determine length of parameter list }
  668. pt:=tcallparanode(left);
  669. paralength:=0;
  670. while assigned(pt) do
  671. begin
  672. inc(paralength);
  673. pt:=tcallparanode(pt.right);
  674. end;
  675. { link all procedures which have the same # of parameters }
  676. pd:=aktcallprocsym^.definition;
  677. while assigned(pd) do
  678. begin
  679. { only when the # of parameter are supported by the
  680. procedure }
  681. if (paralength>=pd^.minparacount) and (paralength<=pd^.maxparacount) then
  682. begin
  683. new(hp);
  684. hp^.data:=pd;
  685. hp^.next:=procs;
  686. hp^.firstpara:=tparaitem(pd^.Para.first);
  687. { if not all parameters are given, then skip the
  688. default parameters }
  689. for i:=1 to pd^.maxparacount-paralength do
  690. hp^.firstpara:=tparaitem(hp^.firstPara.next);
  691. hp^.nextpara:=hp^.firstpara;
  692. procs:=hp;
  693. end;
  694. pd:=pd^.nextoverloaded;
  695. end;
  696. { no procedures found? then there is something wrong
  697. with the parameter size }
  698. if not assigned(procs) then
  699. begin
  700. { in tp mode we can try to convert to procvar if
  701. there are no parameters specified }
  702. if not(assigned(left)) and
  703. (m_tp_procvar in aktmodeswitches) then
  704. begin
  705. hpt:=cloadnode.create(pprocsym(symtableprocentry),symtableproc);
  706. if (symtableprocentry^.owner^.symtabletype=objectsymtable) and
  707. assigned(methodpointer) then
  708. tloadnode(hpt).set_mp(methodpointer.getcopy);
  709. resulttypepass(hpt);
  710. right:=hpt;
  711. end
  712. else
  713. begin
  714. if assigned(left) then
  715. aktfilepos:=left.fileinfo;
  716. CGMessage(parser_e_wrong_parameter_size);
  717. aktcallprocsym^.write_parameter_lists(nil);
  718. end;
  719. goto errorexit;
  720. end;
  721. { now we can compare parameter after parameter }
  722. pt:=tcallparanode(left);
  723. { we start with the last parameter }
  724. lastpara:=paralength+1;
  725. lastparatype:=nil;
  726. while assigned(pt) do
  727. begin
  728. dec(lastpara);
  729. { walk all procedures and determine how this parameter matches and set:
  730. 1. pt.exact_match_found if one parameter has an exact match
  731. 2. exactmatch if an equal or exact match is found
  732. 3. Para.argconvtyp to exact,equal or convertable
  733. (when convertable then also convertlevel is set)
  734. 4. pt.convlevel1found if there is a convertlevel=1
  735. 5. pt.convlevel2found if there is a convertlevel=2
  736. }
  737. exactmatch:=false;
  738. hp:=procs;
  739. while assigned(hp) do
  740. begin
  741. if is_equal(pt,hp^.nextPara.paratype.def) then
  742. begin
  743. if hp^.nextPara.paratype.def=pt.resulttype.def then
  744. begin
  745. include(pt.callparaflags,cpf_exact_match_found);
  746. hp^.nextPara.argconvtyp:=act_exact;
  747. end
  748. else
  749. hp^.nextPara.argconvtyp:=act_equal;
  750. exactmatch:=true;
  751. end
  752. else
  753. begin
  754. hp^.nextPara.argconvtyp:=act_convertable;
  755. hp^.nextPara.convertlevel:=isconvertable(pt.resulttype.def,hp^.nextPara.paratype.def,
  756. hcvt,pt.left.nodetype,false);
  757. case hp^.nextPara.convertlevel of
  758. 1 : include(pt.callparaflags,cpf_convlevel1found);
  759. 2 : include(pt.callparaflags,cpf_convlevel2found);
  760. end;
  761. end;
  762. hp:=hp^.next;
  763. end;
  764. { If there was an exactmatch then delete all convertables }
  765. if exactmatch then
  766. begin
  767. hp:=procs;
  768. procs:=nil;
  769. while assigned(hp) do
  770. begin
  771. hp2:=hp^.next;
  772. { keep if not convertable }
  773. if (hp^.nextPara.argconvtyp<>act_convertable) then
  774. begin
  775. hp^.next:=procs;
  776. procs:=hp;
  777. end
  778. else
  779. dispose(hp);
  780. hp:=hp2;
  781. end;
  782. end
  783. else
  784. { No exact match was found, remove all procedures that are
  785. not convertable (convertlevel=0) }
  786. begin
  787. hp:=procs;
  788. procs:=nil;
  789. while assigned(hp) do
  790. begin
  791. hp2:=hp^.next;
  792. { keep if not convertable }
  793. if (hp^.nextPara.convertlevel<>0) then
  794. begin
  795. hp^.next:=procs;
  796. procs:=hp;
  797. end
  798. else
  799. begin
  800. { save the type for nice error message }
  801. lastparatype:=hp^.nextPara.paratype.def;
  802. dispose(hp);
  803. end;
  804. hp:=hp2;
  805. end;
  806. end;
  807. { update nextpara for all procedures }
  808. hp:=procs;
  809. while assigned(hp) do
  810. begin
  811. hp^.nextpara:=tparaitem(hp^.nextPara.next);
  812. hp:=hp^.next;
  813. end;
  814. { load next parameter or quit loop if no procs left }
  815. if assigned(procs) then
  816. pt:=tcallparanode(pt.right)
  817. else
  818. break;
  819. end;
  820. { All parameters are checked, check if there are any
  821. procedures left }
  822. if not assigned(procs) then
  823. begin
  824. { there is an error, must be wrong type, because
  825. wrong size is already checked (PFV) }
  826. if (not assigned(lastparatype)) or
  827. (not assigned(pt)) or
  828. (not assigned(pt.resulttype.def)) then
  829. internalerror(39393)
  830. else
  831. begin
  832. aktfilepos:=pt.fileinfo;
  833. CGMessage3(type_e_wrong_parameter_type,tostr(lastpara),
  834. pt.resulttype.def^.typename,lastparatype^.typename);
  835. end;
  836. aktcallprocsym^.write_parameter_lists(nil);
  837. goto errorexit;
  838. end;
  839. { if there are several choices left then for orddef }
  840. { if a type is totally included in the other }
  841. { we don't fear an overflow , }
  842. { so we can do as if it is an exact match }
  843. { this will convert integer to longint }
  844. { rather than to words }
  845. { conversion of byte to integer or longint }
  846. {would still not be solved }
  847. if assigned(procs) and assigned(procs^.next) then
  848. begin
  849. hp:=procs;
  850. while assigned(hp) do
  851. begin
  852. hp^.nextpara:=hp^.firstpara;
  853. hp:=hp^.next;
  854. end;
  855. pt:=tcallparanode(left);
  856. while assigned(pt) do
  857. begin
  858. { matches a parameter of one procedure exact ? }
  859. exactmatch:=false;
  860. def_from:=pt.resulttype.def;
  861. hp:=procs;
  862. while assigned(hp) do
  863. begin
  864. if not is_equal(pt,hp^.nextPara.paratype.def) then
  865. begin
  866. def_to:=hp^.nextPara.paratype.def;
  867. if ((def_from^.deftype=orddef) and (def_to^.deftype=orddef)) and
  868. (is_in_limit(def_from,def_to) or
  869. ((hp^.nextPara.paratyp in [vs_var,vs_out]) and
  870. (def_from^.size=def_to^.size))) then
  871. begin
  872. exactmatch:=true;
  873. conv_to:=def_to;
  874. end;
  875. end;
  876. hp:=hp^.next;
  877. end;
  878. { .... if yes, del all the other procedures }
  879. if exactmatch then
  880. begin
  881. { the first .... }
  882. while (assigned(procs)) and not(is_in_limit(def_from,procs^.nextPara.paratype.def)) do
  883. begin
  884. hp:=procs^.next;
  885. dispose(procs);
  886. procs:=hp;
  887. end;
  888. { and the others }
  889. hp:=procs;
  890. while (assigned(hp)) and assigned(hp^.next) do
  891. begin
  892. if not(is_in_limit(def_from,hp^.next^.nextPara.paratype.def)) then
  893. begin
  894. hp2:=hp^.next^.next;
  895. dispose(hp^.next);
  896. hp^.next:=hp2;
  897. end
  898. else
  899. begin
  900. def_to:=hp^.next^.nextPara.paratype.def;
  901. if (conv_to^.size>def_to^.size) or
  902. ((porddef(conv_to)^.low<porddef(def_to)^.low) and
  903. (porddef(conv_to)^.high>porddef(def_to)^.high)) then
  904. begin
  905. hp2:=procs;
  906. procs:=hp;
  907. conv_to:=def_to;
  908. dispose(hp2);
  909. end
  910. else
  911. hp:=hp^.next;
  912. end;
  913. end;
  914. end;
  915. { update nextpara for all procedures }
  916. hp:=procs;
  917. while assigned(hp) do
  918. begin
  919. hp^.nextpara:=tparaitem(hp^.nextPara.next);
  920. hp:=hp^.next;
  921. end;
  922. pt:=tcallparanode(pt.right);
  923. end;
  924. end;
  925. { let's try to eliminate equal if there is an exact match
  926. is there }
  927. if assigned(procs) and assigned(procs^.next) then
  928. begin
  929. { reset nextpara for all procs left }
  930. hp:=procs;
  931. while assigned(hp) do
  932. begin
  933. hp^.nextpara:=hp^.firstpara;
  934. hp:=hp^.next;
  935. end;
  936. pt:=tcallparanode(left);
  937. while assigned(pt) do
  938. begin
  939. if cpf_exact_match_found in pt.callparaflags then
  940. begin
  941. hp:=procs;
  942. procs:=nil;
  943. while assigned(hp) do
  944. begin
  945. hp2:=hp^.next;
  946. { keep the exact matches, dispose the others }
  947. if (hp^.nextPara.argconvtyp=act_exact) then
  948. begin
  949. hp^.next:=procs;
  950. procs:=hp;
  951. end
  952. else
  953. dispose(hp);
  954. hp:=hp2;
  955. end;
  956. end;
  957. { update nextpara for all procedures }
  958. hp:=procs;
  959. while assigned(hp) do
  960. begin
  961. hp^.nextpara:=tparaitem(hp^.nextPara.next);
  962. hp:=hp^.next;
  963. end;
  964. pt:=tcallparanode(pt.right);
  965. end;
  966. end;
  967. { Check if there are integer constant to integer
  968. parameters then choose the best matching integer
  969. parameter and remove the others, this is Delphi
  970. compatible. 1 = byte, 256 = word, etc. }
  971. if assigned(procs) and assigned(procs^.next) then
  972. begin
  973. { reset nextpara for all procs left }
  974. hp:=procs;
  975. while assigned(hp) do
  976. begin
  977. hp^.nextpara:=hp^.firstpara;
  978. hp:=hp^.next;
  979. end;
  980. pt:=tcallparanode(left);
  981. while assigned(pt) do
  982. begin
  983. bestord:=nil;
  984. if (pt.left.nodetype=ordconstn) and
  985. is_integer(pt.resulttype.def) then
  986. begin
  987. hp:=procs;
  988. while assigned(hp) do
  989. begin
  990. def_to:=hp^.nextPara.paratype.def;
  991. { to be sure, it couldn't be something else,
  992. also the defs here are all in the range
  993. so now find the closest range }
  994. if not is_integer(def_to) then
  995. internalerror(43297815);
  996. if (not assigned(bestord)) or
  997. ((porddef(def_to)^.low>bestord^.low) or
  998. (porddef(def_to)^.high<bestord^.high)) then
  999. bestord:=porddef(def_to);
  1000. hp:=hp^.next;
  1001. end;
  1002. end;
  1003. { if a bestmatch is found then remove the other
  1004. procs which don't match the bestord }
  1005. if assigned(bestord) then
  1006. begin
  1007. hp:=procs;
  1008. procs:=nil;
  1009. while assigned(hp) do
  1010. begin
  1011. hp2:=hp^.next;
  1012. { keep matching bestord, dispose the others }
  1013. if (porddef(hp^.nextPara.paratype.def)=bestord) then
  1014. begin
  1015. hp^.next:=procs;
  1016. procs:=hp;
  1017. end
  1018. else
  1019. dispose(hp);
  1020. hp:=hp2;
  1021. end;
  1022. end;
  1023. { update nextpara for all procedures }
  1024. hp:=procs;
  1025. while assigned(hp) do
  1026. begin
  1027. hp^.nextpara:=tparaitem(hp^.nextPara.next);
  1028. hp:=hp^.next;
  1029. end;
  1030. pt:=tcallparanode(pt.right);
  1031. end;
  1032. end;
  1033. { Check if there are convertlevel 1 and 2 differences
  1034. left for the parameters, then discard all convertlevel
  1035. 2 procedures. The value of convlevelXfound can still
  1036. be used, because all convertables are still here or
  1037. not }
  1038. if assigned(procs) and assigned(procs^.next) then
  1039. begin
  1040. { reset nextpara for all procs left }
  1041. hp:=procs;
  1042. while assigned(hp) do
  1043. begin
  1044. hp^.nextpara:=hp^.firstpara;
  1045. hp:=hp^.next;
  1046. end;
  1047. pt:=tcallparanode(left);
  1048. while assigned(pt) do
  1049. begin
  1050. if (cpf_convlevel1found in pt.callparaflags) and
  1051. (cpf_convlevel2found in pt.callparaflags) then
  1052. begin
  1053. hp:=procs;
  1054. procs:=nil;
  1055. while assigned(hp) do
  1056. begin
  1057. hp2:=hp^.next;
  1058. { keep all not act_convertable and all convertlevels=1 }
  1059. if (hp^.nextPara.argconvtyp<>act_convertable) or
  1060. (hp^.nextPara.convertlevel=1) then
  1061. begin
  1062. hp^.next:=procs;
  1063. procs:=hp;
  1064. end
  1065. else
  1066. dispose(hp);
  1067. hp:=hp2;
  1068. end;
  1069. end;
  1070. { update nextpara for all procedures }
  1071. hp:=procs;
  1072. while assigned(hp) do
  1073. begin
  1074. hp^.nextpara:=tparaitem(hp^.nextPara.next);
  1075. hp:=hp^.next;
  1076. end;
  1077. pt:=tcallparanode(pt.right);
  1078. end;
  1079. end;
  1080. if not(assigned(procs)) or assigned(procs^.next) then
  1081. begin
  1082. CGMessage(cg_e_cant_choose_overload_function);
  1083. aktcallprocsym^.write_parameter_lists(nil);
  1084. goto errorexit;
  1085. end;
  1086. {$ifdef TEST_PROCSYMS}
  1087. if (procs=nil) and assigned(nextprocsym) then
  1088. begin
  1089. symtableprocentry:=nextprocsym;
  1090. symtableproc:=symt;
  1091. end;
  1092. end ; { of while assigned(symtableprocentry) do }
  1093. {$endif TEST_PROCSYMS}
  1094. if make_ref then
  1095. begin
  1096. procs^.data^.lastref:=new(pref,init(procs^.data^.lastref,@fileinfo));
  1097. inc(procs^.data^.refcount);
  1098. if procs^.data^.defref=nil then
  1099. procs^.data^.defref:=procs^.data^.lastref;
  1100. end;
  1101. procdefinition:=procs^.data;
  1102. { big error for with statements
  1103. symtableproc:=procdefinition^.owner;
  1104. but neede for overloaded operators !! }
  1105. if symtableproc=nil then
  1106. symtableproc:=procdefinition^.owner;
  1107. {$ifdef CHAINPROCSYMS}
  1108. { object with method read;
  1109. call to read(x) will be a usual procedure call }
  1110. if assigned(methodpointer) and
  1111. (procdefinition^._class=nil) then
  1112. begin
  1113. { not ok for extended }
  1114. case methodpointer^.nodetype of
  1115. typen,hnewn : fatalerror(no_para_match);
  1116. end;
  1117. methodpointer.free;
  1118. methodpointer:=nil;
  1119. end;
  1120. {$endif CHAINPROCSYMS}
  1121. end; { end of procedure to call determination }
  1122. { add needed default parameters }
  1123. if assigned(procs) and
  1124. (paralength<procdefinition^.maxparacount) then
  1125. begin
  1126. { add default parameters, just read back the skipped
  1127. paras starting from firstPara.previous, when not available
  1128. (all parameters are default) then start with the last
  1129. parameter and read backward (PFV) }
  1130. if not assigned(procs^.firstpara) then
  1131. pdc:=tparaitem(procs^.data^.Para.last)
  1132. else
  1133. pdc:=tparaitem(procs^.firstPara.previous);
  1134. while assigned(pdc) do
  1135. begin
  1136. if not assigned(pdc.defaultvalue) then
  1137. internalerror(751349858);
  1138. left:=ccallparanode.create(genconstsymtree(pconstsym(pdc.defaultvalue)),left);
  1139. pdc:=tparaitem(pdc.previous);
  1140. end;
  1141. end;
  1142. end;
  1143. { handle predefined procedures }
  1144. is_const:=(pocall_internconst in procdefinition^.proccalloptions) and
  1145. ((block_type in [bt_const,bt_type]) or
  1146. (assigned(left) and (tcallparanode(left).left.nodetype in [realconstn,ordconstn])));
  1147. if (pocall_internproc in procdefinition^.proccalloptions) or is_const then
  1148. begin
  1149. if assigned(left) then
  1150. begin
  1151. hpt2:=left;
  1152. left:=nil;
  1153. { ptr and settextbuf needs two args }
  1154. if assigned(tcallparanode(hpt2).right) then
  1155. hpt:=geninlinenode(pprocdef(procdefinition)^.extnumber,is_const,hpt2)
  1156. else
  1157. hpt:=geninlinenode(pprocdef(procdefinition)^.extnumber,is_const,tcallparanode(hpt2).left);
  1158. end
  1159. else
  1160. hpt:=geninlinenode(pprocdef(procdefinition)^.extnumber,is_const,nil);
  1161. firstpass(hpt);
  1162. result:=hpt;
  1163. goto errorexit;
  1164. end;
  1165. { Calling a message method directly ? }
  1166. if assigned(procdefinition) and
  1167. (po_containsself in procdefinition^.procoptions) then
  1168. message(cg_e_cannot_call_message_direct);
  1169. { ensure that the result type is set }
  1170. resulttype:=procdefinition^.rettype;
  1171. { constructors return their current class type, not the type where the
  1172. constructor is declared, this can be different because of inheritance }
  1173. if (procdefinition^.proctypeoption=potype_constructor) then
  1174. begin
  1175. if assigned(methodpointer) and
  1176. assigned(methodpointer.resulttype.def) and
  1177. (methodpointer.resulttype.def^.deftype=classrefdef) then
  1178. resulttype:=pclassrefdef(methodpointer.resulttype.def)^.pointertype;
  1179. end;
  1180. { insert type conversions }
  1181. if assigned(left) then
  1182. tcallparanode(left).insert_typeconv(tparaitem(procdefinition^.Para.first),true);
  1183. errorexit:
  1184. { Reset some settings back }
  1185. if assigned(procs) then
  1186. dispose(procs);
  1187. aktcallprocsym:=oldcallprocsym;
  1188. end;
  1189. function tcallnode.pass_1 : tnode;
  1190. var
  1191. hpt,hpt2,inlinecode : tnode;
  1192. inlined : boolean;
  1193. {$ifdef m68k}
  1194. regi : tregister;
  1195. {$endif}
  1196. method_must_be_valid : boolean;
  1197. label
  1198. errorexit;
  1199. var
  1200. is_const : boolean;
  1201. begin
  1202. result:=nil;
  1203. inlined:=false;
  1204. { work trough all parameters to get the register requirements }
  1205. if assigned(left) then
  1206. tcallparanode(left).det_registers;
  1207. if assigned(procdefinition) and
  1208. (pocall_inline in procdefinition^.proccalloptions) then
  1209. begin
  1210. inlinecode:=right;
  1211. if assigned(inlinecode) then
  1212. begin
  1213. inlined:=true;
  1214. exclude(procdefinition^.proccalloptions,pocall_inline);
  1215. end;
  1216. right:=nil;
  1217. end;
  1218. { procedure variable ? }
  1219. if assigned(right) then
  1220. begin
  1221. firstpass(right);
  1222. { procedure does a call }
  1223. if not (block_type in [bt_const,bt_type]) then
  1224. procinfo^.flags:=procinfo^.flags or pi_do_call;
  1225. {$ifndef newcg}
  1226. { calc the correture value for the register }
  1227. {$ifdef i386}
  1228. incrementregisterpushed($ff);
  1229. {$endif}
  1230. {$ifdef m68k}
  1231. for regi:=R_D0 to R_A6 do
  1232. inc(reg_pushes[regi],t_times*2);
  1233. {$endif}
  1234. {$endif newcg}
  1235. end
  1236. else
  1237. { not a procedure variable }
  1238. begin
  1239. location.loc:=LOC_MEM;
  1240. { calc the correture value for the register }
  1241. { handle predefined procedures }
  1242. if (pocall_inline in procdefinition^.proccalloptions) then
  1243. begin
  1244. if assigned(methodpointer) then
  1245. CGMessage(cg_e_unable_inline_object_methods);
  1246. if assigned(right) and (right.nodetype<>procinlinen) then
  1247. CGMessage(cg_e_unable_inline_procvar);
  1248. { nodetype:=procinlinen; }
  1249. if not assigned(right) then
  1250. begin
  1251. if assigned(pprocdef(procdefinition)^.code) then
  1252. inlinecode:=cprocinlinenode.create(self,tnode(pprocdef(procdefinition)^.code))
  1253. else
  1254. CGMessage(cg_e_no_code_for_inline_stored);
  1255. if assigned(inlinecode) then
  1256. begin
  1257. { consider it has not inlined if called
  1258. again inside the args }
  1259. exclude(procdefinition^.proccalloptions,pocall_inline);
  1260. firstpass(inlinecode);
  1261. inlined:=true;
  1262. end;
  1263. end;
  1264. end
  1265. else
  1266. begin
  1267. if not (block_type in [bt_const,bt_type]) then
  1268. procinfo^.flags:=procinfo^.flags or pi_do_call;
  1269. end;
  1270. {$ifndef newcg}
  1271. {$ifdef i386}
  1272. incrementregisterpushed(pprocdef(procdefinition)^.usedregisters);
  1273. {$endif}
  1274. {$ifdef m68k}
  1275. for regi:=R_D0 to R_A6 do
  1276. begin
  1277. if (pprocdef(procdefinition)^.usedregisters and ($800 shr word(regi)))<>0 then
  1278. inc(reg_pushes[regi],t_times*2);
  1279. end;
  1280. {$endif}
  1281. {$endif newcg}
  1282. end;
  1283. { get a register for the return value }
  1284. if (not is_void(resulttype.def)) then
  1285. begin
  1286. if (procdefinition^.proctypeoption=potype_constructor) then
  1287. begin
  1288. { extra handling of classes }
  1289. { methodpointer should be assigned! }
  1290. if assigned(methodpointer) and
  1291. assigned(methodpointer.resulttype.def) and
  1292. (methodpointer.resulttype.def^.deftype=classrefdef) then
  1293. begin
  1294. location.loc:=LOC_REGISTER;
  1295. registers32:=1;
  1296. end
  1297. { a object constructor returns the result with the flags }
  1298. else
  1299. location.loc:=LOC_FLAGS;
  1300. end
  1301. else
  1302. begin
  1303. {$ifdef SUPPORT_MMX}
  1304. if (cs_mmx in aktlocalswitches) and
  1305. is_mmx_able_array(resulttype.def) then
  1306. begin
  1307. location.loc:=LOC_MMXREGISTER;
  1308. registersmmx:=1;
  1309. end
  1310. else
  1311. {$endif SUPPORT_MMX}
  1312. if ret_in_acc(resulttype.def) then
  1313. begin
  1314. location.loc:=LOC_REGISTER;
  1315. if is_64bitint(resulttype.def) then
  1316. registers32:=2
  1317. else
  1318. registers32:=1;
  1319. { wide- and ansistrings are returned in EAX }
  1320. { but they are imm. moved to a memory location }
  1321. if is_widestring(resulttype.def) or
  1322. is_ansistring(resulttype.def) then
  1323. begin
  1324. location.loc:=LOC_MEM;
  1325. { this is wrong we still need one register PM
  1326. registers32:=0; }
  1327. { we use ansistrings so no fast exit here }
  1328. procinfo^.no_fast_exit:=true;
  1329. registers32:=1;
  1330. end;
  1331. end
  1332. else if (resulttype.def^.deftype=floatdef) then
  1333. begin
  1334. location.loc:=LOC_FPU;
  1335. registersfpu:=1;
  1336. end
  1337. else
  1338. location.loc:=LOC_MEM;
  1339. end;
  1340. end;
  1341. { a fpu can be used in any procedure !! }
  1342. registersfpu:=procdefinition^.fpu_used;
  1343. { if this is a call to a method calc the registers }
  1344. if (methodpointer<>nil) then
  1345. begin
  1346. case methodpointer.nodetype of
  1347. { but only, if this is not a supporting node }
  1348. typen: ;
  1349. { we need one register for new return value PM }
  1350. hnewn : if registers32=0 then
  1351. registers32:=1;
  1352. else
  1353. begin
  1354. if (procdefinition^.proctypeoption in [potype_constructor,potype_destructor]) and
  1355. assigned(symtableproc) and (symtableproc^.symtabletype=withsymtable) and
  1356. not pwithsymtable(symtableproc)^.direct_with then
  1357. begin
  1358. CGmessage(cg_e_cannot_call_cons_dest_inside_with);
  1359. end; { Is accepted by Delphi !! }
  1360. { this is not a good reason to accept it in FPC if we produce
  1361. wrong code for it !!! (PM) }
  1362. { R.Assign is not a constructor !!! }
  1363. { but for R^.Assign, R must be valid !! }
  1364. if (procdefinition^.proctypeoption=potype_constructor) or
  1365. ((methodpointer.nodetype=loadn) and
  1366. (not(oo_has_virtual in pobjectdef(methodpointer.resulttype.def)^.objectoptions))) then
  1367. method_must_be_valid:=false
  1368. else
  1369. method_must_be_valid:=true;
  1370. firstpass(methodpointer);
  1371. set_varstate(methodpointer,method_must_be_valid);
  1372. { The object is already used ven if it is called once }
  1373. if (methodpointer.nodetype=loadn) and
  1374. (tloadnode(methodpointer).symtableentry^.typ=varsym) then
  1375. pvarsym(tloadnode(methodpointer).symtableentry)^.varstate:=vs_used;
  1376. registersfpu:=max(methodpointer.registersfpu,registersfpu);
  1377. registers32:=max(methodpointer.registers32,registers32);
  1378. {$ifdef SUPPORT_MMX}
  1379. registersmmx:=max(methodpointer.registersmmx,registersmmx);
  1380. {$endif SUPPORT_MMX}
  1381. end;
  1382. end;
  1383. end;
  1384. if inlined then
  1385. right:=inlinecode;
  1386. { determine the registers of the procedure variable }
  1387. { is this OK for inlined procs also ?? (PM) }
  1388. if assigned(right) then
  1389. begin
  1390. registersfpu:=max(right.registersfpu,registersfpu);
  1391. registers32:=max(right.registers32,registers32);
  1392. {$ifdef SUPPORT_MMX}
  1393. registersmmx:=max(right.registersmmx,registersmmx);
  1394. {$endif SUPPORT_MMX}
  1395. end;
  1396. { determine the registers of the procedure }
  1397. if assigned(left) then
  1398. begin
  1399. registersfpu:=max(left.registersfpu,registersfpu);
  1400. registers32:=max(left.registers32,registers32);
  1401. {$ifdef SUPPORT_MMX}
  1402. registersmmx:=max(left.registersmmx,registersmmx);
  1403. {$endif SUPPORT_MMX}
  1404. end;
  1405. errorexit:
  1406. if inlined then
  1407. include(procdefinition^.proccalloptions,pocall_inline);
  1408. end;
  1409. function tcallnode.docompare(p: tnode): boolean;
  1410. begin
  1411. docompare :=
  1412. inherited docompare(p) and
  1413. (symtableprocentry = tcallnode(p).symtableprocentry) and
  1414. (symtableproc = tcallnode(p).symtableproc) and
  1415. (procdefinition = tcallnode(p).procdefinition) and
  1416. (methodpointer = tcallnode(p).methodpointer);
  1417. end;
  1418. {****************************************************************************
  1419. TPROCINLINENODE
  1420. ****************************************************************************}
  1421. constructor tprocinlinenode.create(callp,code : tnode);
  1422. begin
  1423. inherited create(procinlinen);
  1424. inlineprocsym:=tcallnode(callp).symtableprocentry;
  1425. retoffset:=-target_os.size_of_pointer; { less dangerous as zero (PM) }
  1426. para_offset:=0;
  1427. para_size:=inlineprocsym^.definition^.para_size(target_os.stackalignment);
  1428. if ret_in_param(inlineprocsym^.definition^.rettype.def) then
  1429. para_size:=para_size+target_os.size_of_pointer;
  1430. { copy args }
  1431. if assigned(code) then
  1432. inlinetree:=code.getcopy
  1433. else inlinetree := nil;
  1434. registers32:=code.registers32;
  1435. registersfpu:=code.registersfpu;
  1436. {$ifdef SUPPORT_MMX}
  1437. registersmmx:=code.registersmmx;
  1438. {$endif SUPPORT_MMX}
  1439. resulttype:=inlineprocsym^.definition^.rettype;
  1440. end;
  1441. destructor tprocinlinenode.destroy;
  1442. begin
  1443. if assigned(inlinetree) then
  1444. inlinetree.free;
  1445. inherited destroy;
  1446. end;
  1447. function tprocinlinenode.getcopy : tnode;
  1448. var
  1449. n : tprocinlinenode;
  1450. begin
  1451. n:=tprocinlinenode(inherited getcopy);
  1452. if assigned(inlinetree) then
  1453. n.inlinetree:=inlinetree.getcopy
  1454. else
  1455. n.inlinetree:=nil;
  1456. n.inlineprocsym:=inlineprocsym;
  1457. n.retoffset:=retoffset;
  1458. n.para_offset:=para_offset;
  1459. n.para_size:=para_size;
  1460. getcopy:=n;
  1461. end;
  1462. procedure tprocinlinenode.insertintolist(l : tnodelist);
  1463. begin
  1464. end;
  1465. function tprocinlinenode.pass_1 : tnode;
  1466. begin
  1467. result:=nil;
  1468. { left contains the code in tree form }
  1469. { but it has already been firstpassed }
  1470. { so firstpass(left); does not seem required }
  1471. { might be required later if we change the arg handling !! }
  1472. end;
  1473. function tprocinlinenode.docompare(p: tnode): boolean;
  1474. begin
  1475. docompare :=
  1476. inherited docompare(p) and
  1477. inlinetree.isequal(tprocinlinenode(p).inlinetree) and
  1478. (inlineprocsym = tprocinlinenode(p).inlineprocsym);
  1479. end;
  1480. begin
  1481. ccallnode:=tcallnode;
  1482. ccallparanode:=tcallparanode;
  1483. cprocinlinenode:=tprocinlinenode;
  1484. end.
  1485. {
  1486. $Log$
  1487. Revision 1.26 2001-04-04 22:42:39 peter
  1488. * move constant folding into det_resulttype
  1489. Revision 1.25 2001/04/02 21:20:30 peter
  1490. * resulttype rewrite
  1491. Revision 1.24 2001/03/12 12:47:46 michael
  1492. + Patches from peter
  1493. Revision 1.23 2001/02/26 19:44:52 peter
  1494. * merged generic m68k updates from fixes branch
  1495. Revision 1.22 2001/01/08 21:46:46 peter
  1496. * don't push high value for open array with cdecl;external;
  1497. Revision 1.21 2000/12/31 11:14:10 jonas
  1498. + implemented/fixed docompare() mathods for all nodes (not tested)
  1499. + nopt.pas, nadd.pas, i386/n386opt.pas: optimized nodes for adding strings
  1500. and constant strings/chars together
  1501. * n386add.pas: don't copy temp strings (of size 256) to another temp string
  1502. when adding
  1503. Revision 1.20 2000/12/25 00:07:26 peter
  1504. + new tlinkedlist class (merge of old tstringqueue,tcontainer and
  1505. tlinkedlist objects)
  1506. Revision 1.19 2000/12/17 14:35:12 peter
  1507. * fixed crash with procvar load in tp mode
  1508. Revision 1.18 2000/11/29 00:30:32 florian
  1509. * unused units removed from uses clause
  1510. * some changes for widestrings
  1511. Revision 1.17 2000/11/22 15:12:06 jonas
  1512. * fixed inline-related problems (partially "merges")
  1513. Revision 1.16 2000/11/11 16:14:52 peter
  1514. * fixed crash with settextbuf,ptr
  1515. Revision 1.15 2000/11/06 21:36:25 peter
  1516. * fixed var parameter varstate bug
  1517. Revision 1.14 2000/11/04 14:25:20 florian
  1518. + merged Attila's changes for interfaces, not tested yet
  1519. Revision 1.13 2000/10/31 22:02:47 peter
  1520. * symtable splitted, no real code changes
  1521. Revision 1.12 2000/10/21 18:16:11 florian
  1522. * a lot of changes:
  1523. - basic dyn. array support
  1524. - basic C++ support
  1525. - some work for interfaces done
  1526. ....
  1527. Revision 1.11 2000/10/21 14:35:27 peter
  1528. * readd to many remove p. for tcallnode.is_equal()
  1529. Revision 1.10 2000/10/14 21:52:55 peter
  1530. * fixed memory leaks
  1531. Revision 1.9 2000/10/14 10:14:50 peter
  1532. * moehrendorf oct 2000 rewrite
  1533. Revision 1.8 2000/10/01 19:48:24 peter
  1534. * lot of compile updates for cg11
  1535. Revision 1.7 2000/09/28 19:49:52 florian
  1536. *** empty log message ***
  1537. Revision 1.6 2000/09/27 18:14:31 florian
  1538. * fixed a lot of syntax errors in the n*.pas stuff
  1539. Revision 1.5 2000/09/24 21:15:34 florian
  1540. * some errors fix to get more stuff compilable
  1541. Revision 1.4 2000/09/24 20:17:44 florian
  1542. * more conversion work done
  1543. Revision 1.3 2000/09/24 15:06:19 peter
  1544. * use defines.inc
  1545. Revision 1.2 2000/09/20 21:52:38 florian
  1546. * removed a lot of errors
  1547. Revision 1.1 2000/09/20 20:52:16 florian
  1548. * initial revision
  1549. }