ncal.pas 65 KB

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