ncal.pas 67 KB

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