ncal.pas 67 KB

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