ncal.pas 69 KB

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