ncal.pas 65 KB

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