ncal.pas 65 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600
  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. assigned(methodpointer) { and
  733. is_class(pdef(symtableprocentry^.owner^.defowner))} then
  734. hpt:=genloadmethodcallnode(pprocsym(symtableprocentry),symtableproc,
  735. methodpointer.getcopy)
  736. else
  737. hpt:=genloadcallnode(pprocsym(symtableprocentry),symtableproc);
  738. firstpass(hpt);
  739. pass_1:=hpt;
  740. end
  741. else
  742. begin
  743. if assigned(left) then
  744. aktfilepos:=left.fileinfo;
  745. CGMessage(parser_e_wrong_parameter_size);
  746. aktcallprocsym^.write_parameter_lists(nil);
  747. end;
  748. goto errorexit;
  749. end;
  750. { now we can compare parameter after parameter }
  751. pt:=tcallparanode(left);
  752. { we start with the last parameter }
  753. lastpara:=paralength+1;
  754. lastparatype:=nil;
  755. while assigned(pt) do
  756. begin
  757. dec(lastpara);
  758. { walk all procedures and determine how this parameter matches and set:
  759. 1. pt.exact_match_found if one parameter has an exact match
  760. 2. exactmatch if an equal or exact match is found
  761. 3. para^.argconvtyp to exact,equal or convertable
  762. (when convertable then also convertlevel is set)
  763. 4. pt.convlevel1found if there is a convertlevel=1
  764. 5. pt.convlevel2found if there is a convertlevel=2
  765. }
  766. exactmatch:=false;
  767. hp:=procs;
  768. while assigned(hp) do
  769. begin
  770. if is_equal(pt,hp^.nextpara^.paratype.def) then
  771. begin
  772. if hp^.nextpara^.paratype.def=pt.resulttype then
  773. begin
  774. include(pt.callparaflags,cpf_exact_match_found);
  775. hp^.nextpara^.argconvtyp:=act_exact;
  776. end
  777. else
  778. hp^.nextpara^.argconvtyp:=act_equal;
  779. exactmatch:=true;
  780. end
  781. else
  782. begin
  783. hp^.nextpara^.argconvtyp:=act_convertable;
  784. hp^.nextpara^.convertlevel:=isconvertable(pt.resulttype,hp^.nextpara^.paratype.def,
  785. hcvt,pt.left,pt.left.nodetype,false);
  786. case hp^.nextpara^.convertlevel of
  787. 1 : include(pt.callparaflags,cpf_convlevel1found);
  788. 2 : include(pt.callparaflags,cpf_convlevel2found);
  789. end;
  790. end;
  791. hp:=hp^.next;
  792. end;
  793. { If there was an exactmatch then delete all convertables }
  794. if exactmatch then
  795. begin
  796. hp:=procs;
  797. procs:=nil;
  798. while assigned(hp) do
  799. begin
  800. hp2:=hp^.next;
  801. { keep if not convertable }
  802. if (hp^.nextpara^.argconvtyp<>act_convertable) then
  803. begin
  804. hp^.next:=procs;
  805. procs:=hp;
  806. end
  807. else
  808. dispose(hp);
  809. hp:=hp2;
  810. end;
  811. end
  812. else
  813. { No exact match was found, remove all procedures that are
  814. not convertable (convertlevel=0) }
  815. begin
  816. hp:=procs;
  817. procs:=nil;
  818. while assigned(hp) do
  819. begin
  820. hp2:=hp^.next;
  821. { keep if not convertable }
  822. if (hp^.nextpara^.convertlevel<>0) then
  823. begin
  824. hp^.next:=procs;
  825. procs:=hp;
  826. end
  827. else
  828. begin
  829. { save the type for nice error message }
  830. lastparatype:=hp^.nextpara^.paratype.def;
  831. dispose(hp);
  832. end;
  833. hp:=hp2;
  834. end;
  835. end;
  836. { update nextpara for all procedures }
  837. hp:=procs;
  838. while assigned(hp) do
  839. begin
  840. hp^.nextpara:=pparaitem(hp^.nextpara^.next);
  841. hp:=hp^.next;
  842. end;
  843. { load next parameter or quit loop if no procs left }
  844. if assigned(procs) then
  845. pt:=tcallparanode(pt.right)
  846. else
  847. break;
  848. end;
  849. { All parameters are checked, check if there are any
  850. procedures left }
  851. if not assigned(procs) then
  852. begin
  853. { there is an error, must be wrong type, because
  854. wrong size is already checked (PFV) }
  855. if (not assigned(lastparatype)) or
  856. (not assigned(pt)) or
  857. (not assigned(pt.resulttype)) then
  858. internalerror(39393)
  859. else
  860. begin
  861. aktfilepos:=pt.fileinfo;
  862. CGMessage3(type_e_wrong_parameter_type,tostr(lastpara),
  863. pt.resulttype^.typename,lastparatype^.typename);
  864. end;
  865. aktcallprocsym^.write_parameter_lists(nil);
  866. goto errorexit;
  867. end;
  868. { if there are several choices left then for orddef }
  869. { if a type is totally included in the other }
  870. { we don't fear an overflow , }
  871. { so we can do as if it is an exact match }
  872. { this will convert integer to longint }
  873. { rather than to words }
  874. { conversion of byte to integer or longint }
  875. {would still not be solved }
  876. if assigned(procs) and assigned(procs^.next) then
  877. begin
  878. hp:=procs;
  879. while assigned(hp) do
  880. begin
  881. hp^.nextpara:=hp^.firstpara;
  882. hp:=hp^.next;
  883. end;
  884. pt:=tcallparanode(left);
  885. while assigned(pt) do
  886. begin
  887. { matches a parameter of one procedure exact ? }
  888. exactmatch:=false;
  889. def_from:=pt.resulttype;
  890. hp:=procs;
  891. while assigned(hp) do
  892. begin
  893. if not is_equal(pt,hp^.nextpara^.paratype.def) then
  894. begin
  895. def_to:=hp^.nextpara^.paratype.def;
  896. if ((def_from^.deftype=orddef) and (def_to^.deftype=orddef)) and
  897. (is_in_limit(def_from,def_to) or
  898. ((hp^.nextpara^.paratyp in [vs_var,vs_out]) and
  899. (def_from^.size=def_to^.size))) then
  900. begin
  901. exactmatch:=true;
  902. conv_to:=def_to;
  903. end;
  904. end;
  905. hp:=hp^.next;
  906. end;
  907. { .... if yes, del all the other procedures }
  908. if exactmatch then
  909. begin
  910. { the first .... }
  911. while (assigned(procs)) and not(is_in_limit(def_from,procs^.nextpara^.paratype.def)) do
  912. begin
  913. hp:=procs^.next;
  914. dispose(procs);
  915. procs:=hp;
  916. end;
  917. { and the others }
  918. hp:=procs;
  919. while (assigned(hp)) and assigned(hp^.next) do
  920. begin
  921. if not(is_in_limit(def_from,hp^.next^.nextpara^.paratype.def)) then
  922. begin
  923. hp2:=hp^.next^.next;
  924. dispose(hp^.next);
  925. hp^.next:=hp2;
  926. end
  927. else
  928. begin
  929. def_to:=hp^.next^.nextpara^.paratype.def;
  930. if (conv_to^.size>def_to^.size) or
  931. ((porddef(conv_to)^.low<porddef(def_to)^.low) and
  932. (porddef(conv_to)^.high>porddef(def_to)^.high)) then
  933. begin
  934. hp2:=procs;
  935. procs:=hp;
  936. conv_to:=def_to;
  937. dispose(hp2);
  938. end
  939. else
  940. hp:=hp^.next;
  941. end;
  942. end;
  943. end;
  944. { update nextpara for all procedures }
  945. hp:=procs;
  946. while assigned(hp) do
  947. begin
  948. hp^.nextpara:=pparaitem(hp^.nextpara^.next);
  949. hp:=hp^.next;
  950. end;
  951. pt:=tcallparanode(pt.right);
  952. end;
  953. end;
  954. { let's try to eliminate equal if there is an exact match
  955. is there }
  956. if assigned(procs) and assigned(procs^.next) then
  957. begin
  958. { reset nextpara for all procs left }
  959. hp:=procs;
  960. while assigned(hp) do
  961. begin
  962. hp^.nextpara:=hp^.firstpara;
  963. hp:=hp^.next;
  964. end;
  965. pt:=tcallparanode(left);
  966. while assigned(pt) do
  967. begin
  968. if cpf_exact_match_found in pt.callparaflags then
  969. begin
  970. hp:=procs;
  971. procs:=nil;
  972. while assigned(hp) do
  973. begin
  974. hp2:=hp^.next;
  975. { keep the exact matches, dispose the others }
  976. if (hp^.nextpara^.argconvtyp=act_exact) then
  977. begin
  978. hp^.next:=procs;
  979. procs:=hp;
  980. end
  981. else
  982. dispose(hp);
  983. hp:=hp2;
  984. end;
  985. end;
  986. { update nextpara for all procedures }
  987. hp:=procs;
  988. while assigned(hp) do
  989. begin
  990. hp^.nextpara:=pparaitem(hp^.nextpara^.next);
  991. hp:=hp^.next;
  992. end;
  993. pt:=tcallparanode(pt.right);
  994. end;
  995. end;
  996. { Check if there are integer constant to integer
  997. parameters then choose the best matching integer
  998. parameter and remove the others, this is Delphi
  999. compatible. 1 = byte, 256 = word, etc. }
  1000. if assigned(procs) and assigned(procs^.next) then
  1001. begin
  1002. { reset nextpara for all procs left }
  1003. hp:=procs;
  1004. while assigned(hp) do
  1005. begin
  1006. hp^.nextpara:=hp^.firstpara;
  1007. hp:=hp^.next;
  1008. end;
  1009. pt:=tcallparanode(left);
  1010. while assigned(pt) do
  1011. begin
  1012. bestord:=nil;
  1013. if (pt.left.nodetype=ordconstn) and
  1014. is_integer(pt.resulttype) then
  1015. begin
  1016. hp:=procs;
  1017. while assigned(hp) do
  1018. begin
  1019. def_to:=hp^.nextpara^.paratype.def;
  1020. { to be sure, it couldn't be something else,
  1021. also the defs here are all in the range
  1022. so now find the closest range }
  1023. if not is_integer(def_to) then
  1024. internalerror(43297815);
  1025. if (not assigned(bestord)) or
  1026. ((porddef(def_to)^.low>bestord^.low) or
  1027. (porddef(def_to)^.high<bestord^.high)) then
  1028. bestord:=porddef(def_to);
  1029. hp:=hp^.next;
  1030. end;
  1031. end;
  1032. { if a bestmatch is found then remove the other
  1033. procs which don't match the bestord }
  1034. if assigned(bestord) then
  1035. begin
  1036. hp:=procs;
  1037. procs:=nil;
  1038. while assigned(hp) do
  1039. begin
  1040. hp2:=hp^.next;
  1041. { keep matching bestord, dispose the others }
  1042. if (porddef(hp^.nextpara^.paratype.def)=bestord) then
  1043. begin
  1044. hp^.next:=procs;
  1045. procs:=hp;
  1046. end
  1047. else
  1048. dispose(hp);
  1049. hp:=hp2;
  1050. end;
  1051. end;
  1052. { update nextpara for all procedures }
  1053. hp:=procs;
  1054. while assigned(hp) do
  1055. begin
  1056. hp^.nextpara:=pparaitem(hp^.nextpara^.next);
  1057. hp:=hp^.next;
  1058. end;
  1059. pt:=tcallparanode(pt.right);
  1060. end;
  1061. end;
  1062. { Check if there are convertlevel 1 and 2 differences
  1063. left for the parameters, then discard all convertlevel
  1064. 2 procedures. The value of convlevelXfound can still
  1065. be used, because all convertables are still here or
  1066. not }
  1067. if assigned(procs) and assigned(procs^.next) then
  1068. begin
  1069. { reset nextpara for all procs left }
  1070. hp:=procs;
  1071. while assigned(hp) do
  1072. begin
  1073. hp^.nextpara:=hp^.firstpara;
  1074. hp:=hp^.next;
  1075. end;
  1076. pt:=tcallparanode(left);
  1077. while assigned(pt) do
  1078. begin
  1079. if (cpf_convlevel1found in pt.callparaflags) and
  1080. (cpf_convlevel2found in pt.callparaflags) then
  1081. begin
  1082. hp:=procs;
  1083. procs:=nil;
  1084. while assigned(hp) do
  1085. begin
  1086. hp2:=hp^.next;
  1087. { keep all not act_convertable and all convertlevels=1 }
  1088. if (hp^.nextpara^.argconvtyp<>act_convertable) or
  1089. (hp^.nextpara^.convertlevel=1) then
  1090. begin
  1091. hp^.next:=procs;
  1092. procs:=hp;
  1093. end
  1094. else
  1095. dispose(hp);
  1096. hp:=hp2;
  1097. end;
  1098. end;
  1099. { update nextpara for all procedures }
  1100. hp:=procs;
  1101. while assigned(hp) do
  1102. begin
  1103. hp^.nextpara:=pparaitem(hp^.nextpara^.next);
  1104. hp:=hp^.next;
  1105. end;
  1106. pt:=tcallparanode(pt.right);
  1107. end;
  1108. end;
  1109. if not(assigned(procs)) or assigned(procs^.next) then
  1110. begin
  1111. CGMessage(cg_e_cant_choose_overload_function);
  1112. aktcallprocsym^.write_parameter_lists(nil);
  1113. goto errorexit;
  1114. end;
  1115. {$ifdef TEST_PROCSYMS}
  1116. if (procs=nil) and assigned(nextprocsym) then
  1117. begin
  1118. symtableprocentry:=nextprocsym;
  1119. symtableproc:=symt;
  1120. end;
  1121. end ; { of while assigned(symtableprocentry) do }
  1122. {$endif TEST_PROCSYMS}
  1123. if make_ref then
  1124. begin
  1125. procs^.data^.lastref:=new(pref,init(procs^.data^.lastref,@fileinfo));
  1126. inc(procs^.data^.refcount);
  1127. if procs^.data^.defref=nil then
  1128. procs^.data^.defref:=procs^.data^.lastref;
  1129. end;
  1130. procdefinition:=procs^.data;
  1131. resulttype:=procs^.data^.rettype.def;
  1132. { big error for with statements
  1133. symtableproc:=procdefinition^.owner;
  1134. but neede for overloaded operators !! }
  1135. if symtableproc=nil then
  1136. symtableproc:=procdefinition^.owner;
  1137. location.loc:=LOC_MEM;
  1138. {$ifdef CHAINPROCSYMS}
  1139. { object with method read;
  1140. call to read(x) will be a usual procedure call }
  1141. if assigned(methodpointer) and
  1142. (procdefinition^._class=nil) then
  1143. begin
  1144. { not ok for extended }
  1145. case methodpointer^.nodetype of
  1146. typen,hnewn : fatalerror(no_para_match);
  1147. end;
  1148. methodpointer.free;
  1149. methodpointer:=nil;
  1150. end;
  1151. {$endif CHAINPROCSYMS}
  1152. end; { end of procedure to call determination }
  1153. is_const:=(pocall_internconst in procdefinition^.proccalloptions) and
  1154. ((block_type in [bt_const,bt_type]) or
  1155. (assigned(left) and (tcallparanode(left).left.nodetype in [realconstn,ordconstn])));
  1156. { handle predefined procedures }
  1157. if (pocall_internproc in procdefinition^.proccalloptions) or is_const then
  1158. begin
  1159. if assigned(left) then
  1160. begin
  1161. hpt2:=left;
  1162. left:=nil;
  1163. { ptr and settextbuf needs two args }
  1164. if assigned(tcallparanode(hpt2).right) then
  1165. hpt:=geninlinenode(pprocdef(procdefinition)^.extnumber,is_const,hpt2)
  1166. else
  1167. hpt:=geninlinenode(pprocdef(procdefinition)^.extnumber,is_const,tcallparanode(hpt2).left);
  1168. end
  1169. else
  1170. hpt:=geninlinenode(pprocdef(procdefinition)^.extnumber,is_const,nil);
  1171. firstpass(hpt);
  1172. pass_1:=hpt;
  1173. goto errorexit;
  1174. end
  1175. else
  1176. { no intern procedure => we do a call }
  1177. { calc the correture value for the register }
  1178. { handle predefined procedures }
  1179. if (pocall_inline in procdefinition^.proccalloptions) then
  1180. begin
  1181. if assigned(methodpointer) then
  1182. CGMessage(cg_e_unable_inline_object_methods);
  1183. if assigned(right) and (right.nodetype<>procinlinen) then
  1184. CGMessage(cg_e_unable_inline_procvar);
  1185. { nodetype:=procinlinen; }
  1186. if not assigned(right) then
  1187. begin
  1188. if assigned(pprocdef(procdefinition)^.code) then
  1189. inlinecode:=genprocinlinenode(self,tnode(pprocdef(procdefinition)^.code))
  1190. else
  1191. CGMessage(cg_e_no_code_for_inline_stored);
  1192. if assigned(inlinecode) then
  1193. begin
  1194. { consider it has not inlined if called
  1195. again inside the args }
  1196. exclude(procdefinition^.proccalloptions,pocall_inline);
  1197. firstpass(inlinecode);
  1198. inlined:=true;
  1199. end;
  1200. end;
  1201. end
  1202. else
  1203. begin
  1204. if not (block_type in [bt_const,bt_type]) then
  1205. procinfo^.flags:=procinfo^.flags or pi_do_call;
  1206. end;
  1207. { add needed default parameters }
  1208. if assigned(procs) and
  1209. (paralength<procdefinition^.maxparacount) then
  1210. begin
  1211. { add default parameters, just read back the skipped
  1212. paras starting from firstpara^.previous, when not available
  1213. (all parameters are default) then start with the last
  1214. parameter and read backward (PFV) }
  1215. if not assigned(procs^.firstpara) then
  1216. pdc:=pparaitem(procs^.data^.para^.last)
  1217. else
  1218. pdc:=pparaitem(procs^.firstpara^.previous);
  1219. while assigned(pdc) do
  1220. begin
  1221. if not assigned(pdc^.defaultvalue) then
  1222. internalerror(751349858);
  1223. left:=gencallparanode(genconstsymtree(pconstsym(pdc^.defaultvalue)),left);
  1224. pdc:=pparaitem(pdc^.previous);
  1225. end;
  1226. end;
  1227. { work trough all parameters to insert the type conversions }
  1228. if assigned(left) then
  1229. tcallparanode(left).firstcallparan(pparaitem(procdefinition^.para^.first),true);
  1230. {$ifndef newcg}
  1231. {$ifdef i386}
  1232. incrementregisterpushed(pprocdef(procdefinition)^.usedregisters);
  1233. {$endif}
  1234. {$ifdef m68k}
  1235. for regi:=R_D0 to R_A6 do
  1236. begin
  1237. if (pprocdef(procdefinition)^.usedregisters and ($800 shr word(regi)))<>0 then
  1238. inc(reg_pushes[regi],t_times*2);
  1239. end;
  1240. {$endif}
  1241. {$endif newcg}
  1242. end;
  1243. { ensure that the result type is set }
  1244. resulttype:=procdefinition^.rettype.def;
  1245. { get a register for the return value }
  1246. if (resulttype<>pdef(voiddef)) then
  1247. begin
  1248. if (procdefinition^.proctypeoption=potype_constructor) then
  1249. begin
  1250. { extra handling of classes }
  1251. { methodpointer should be assigned! }
  1252. if assigned(methodpointer) and assigned(methodpointer.resulttype) and
  1253. (methodpointer.resulttype^.deftype=classrefdef) then
  1254. begin
  1255. location.loc:=LOC_REGISTER;
  1256. registers32:=1;
  1257. { the result type depends on the classref }
  1258. resulttype:=pclassrefdef(methodpointer.resulttype)^.pointertype.def;
  1259. end
  1260. { a object constructor returns the result with the flags }
  1261. else
  1262. location.loc:=LOC_FLAGS;
  1263. end
  1264. else
  1265. begin
  1266. {$ifdef SUPPORT_MMX}
  1267. if (cs_mmx in aktlocalswitches) and
  1268. is_mmx_able_array(resulttype) then
  1269. begin
  1270. location.loc:=LOC_MMXREGISTER;
  1271. registersmmx:=1;
  1272. end
  1273. else
  1274. {$endif SUPPORT_MMX}
  1275. if ret_in_acc(resulttype) then
  1276. begin
  1277. location.loc:=LOC_REGISTER;
  1278. if is_64bitint(resulttype) then
  1279. registers32:=2
  1280. else
  1281. registers32:=1;
  1282. { wide- and ansistrings are returned in EAX }
  1283. { but they are imm. moved to a memory location }
  1284. if is_widestring(resulttype) or
  1285. is_ansistring(resulttype) then
  1286. begin
  1287. location.loc:=LOC_MEM;
  1288. { this is wrong we still need one register PM
  1289. registers32:=0; }
  1290. { we use ansistrings so no fast exit here }
  1291. procinfo^.no_fast_exit:=true;
  1292. registers32:=1;
  1293. end;
  1294. end
  1295. else if (resulttype^.deftype=floatdef) then
  1296. begin
  1297. location.loc:=LOC_FPU;
  1298. registersfpu:=1;
  1299. end
  1300. else
  1301. location.loc:=LOC_MEM;
  1302. end;
  1303. end;
  1304. { a fpu can be used in any procedure !! }
  1305. registersfpu:=procdefinition^.fpu_used;
  1306. { if this is a call to a method calc the registers }
  1307. if (methodpointer<>nil) then
  1308. begin
  1309. case methodpointer.nodetype of
  1310. { but only, if this is not a supporting node }
  1311. typen: ;
  1312. { we need one register for new return value PM }
  1313. hnewn : if registers32=0 then
  1314. registers32:=1;
  1315. else
  1316. begin
  1317. if (procdefinition^.proctypeoption in [potype_constructor,potype_destructor]) and
  1318. assigned(symtableproc) and (symtableproc^.symtabletype=withsymtable) and
  1319. not pwithsymtable(symtableproc)^.direct_with then
  1320. begin
  1321. CGmessage(cg_e_cannot_call_cons_dest_inside_with);
  1322. end; { Is accepted by Delphi !! }
  1323. { this is not a good reason to accept it in FPC if we produce
  1324. wrong code for it !!! (PM) }
  1325. { R.Assign is not a constructor !!! }
  1326. { but for R^.Assign, R must be valid !! }
  1327. if (procdefinition^.proctypeoption=potype_constructor) or
  1328. ((methodpointer.nodetype=loadn) and
  1329. (not(oo_has_virtual in pobjectdef(methodpointer.resulttype)^.objectoptions))) then
  1330. method_must_be_valid:=false
  1331. else
  1332. method_must_be_valid:=true;
  1333. firstpass(methodpointer);
  1334. set_varstate(methodpointer,method_must_be_valid);
  1335. { The object is already used ven if it is called once }
  1336. if (methodpointer.nodetype=loadn) and
  1337. (tloadnode(methodpointer).symtableentry^.typ=varsym) then
  1338. pvarsym(tloadnode(methodpointer).symtableentry)^.varstate:=vs_used;
  1339. registersfpu:=max(methodpointer.registersfpu,registersfpu);
  1340. registers32:=max(methodpointer.registers32,registers32);
  1341. {$ifdef SUPPORT_MMX}
  1342. registersmmx:=max(methodpointer.registersmmx,registersmmx);
  1343. {$endif SUPPORT_MMX}
  1344. end;
  1345. end;
  1346. end;
  1347. if inlined then
  1348. right:=inlinecode;
  1349. { determine the registers of the procedure variable }
  1350. { is this OK for inlined procs also ?? (PM) }
  1351. if assigned(right) then
  1352. begin
  1353. registersfpu:=max(right.registersfpu,registersfpu);
  1354. registers32:=max(right.registers32,registers32);
  1355. {$ifdef SUPPORT_MMX}
  1356. registersmmx:=max(right.registersmmx,registersmmx);
  1357. {$endif SUPPORT_MMX}
  1358. end;
  1359. { determine the registers of the procedure }
  1360. if assigned(left) then
  1361. begin
  1362. registersfpu:=max(left.registersfpu,registersfpu);
  1363. registers32:=max(left.registers32,registers32);
  1364. {$ifdef SUPPORT_MMX}
  1365. registersmmx:=max(left.registersmmx,registersmmx);
  1366. {$endif SUPPORT_MMX}
  1367. end;
  1368. errorexit:
  1369. { Reset some settings back }
  1370. if assigned(procs) then
  1371. dispose(procs);
  1372. if inlined then
  1373. include(procdefinition^.proccalloptions,pocall_inline);
  1374. aktcallprocsym:=oldcallprocsym;
  1375. end;
  1376. {****************************************************************************
  1377. TPROCINLINENODE
  1378. ****************************************************************************}
  1379. constructor tprocinlinenode.create(callp,code : tnode);
  1380. begin
  1381. inherited create(procinlinen);
  1382. inlineprocsym:=tcallnode(callp).symtableprocentry;
  1383. retoffset:=-4; { less dangerous as zero (PM) }
  1384. para_offset:=0;
  1385. para_size:=inlineprocsym^.definition^.para_size(target_os.stackalignment);
  1386. if ret_in_param(inlineprocsym^.definition^.rettype.def) then
  1387. para_size:=para_size+target_os.size_of_pointer;
  1388. { copy args }
  1389. if assigned(code) then
  1390. inlinetree:=code.getcopy
  1391. else inlinetree := nil;
  1392. registers32:=code.registers32;
  1393. registersfpu:=code.registersfpu;
  1394. {$ifdef SUPPORT_MMX}
  1395. registersmmx:=code.registersmmx;
  1396. {$endif SUPPORT_MMX}
  1397. resulttype:=inlineprocsym^.definition^.rettype.def;
  1398. end;
  1399. destructor tprocinlinenode.destroy;
  1400. begin
  1401. if assigned(inlinetree) then
  1402. inlinetree.free;
  1403. inherited destroy;
  1404. end;
  1405. function tprocinlinenode.getcopy : tnode;
  1406. var
  1407. n : tprocinlinenode;
  1408. begin
  1409. n:=tprocinlinenode(inherited getcopy);
  1410. if assigned(inlinetree) then
  1411. n.inlinetree:=inlinetree.getcopy
  1412. else
  1413. n.inlinetree:=nil;
  1414. n.inlineprocsym:=inlineprocsym;
  1415. n.retoffset:=retoffset;
  1416. n.para_offset:=para_offset;
  1417. n.para_size:=para_size;
  1418. getcopy:=n;
  1419. end;
  1420. procedure tprocinlinenode.insertintolist(l : tnodelist);
  1421. begin
  1422. end;
  1423. function tprocinlinenode.pass_1 : tnode;
  1424. begin
  1425. pass_1:=nil;
  1426. { left contains the code in tree form }
  1427. { but it has already been firstpassed }
  1428. { so firstpass(left); does not seem required }
  1429. { might be required later if we change the arg handling !! }
  1430. end;
  1431. begin
  1432. ccallnode:=tcallnode;
  1433. ccallparanode:=tcallparanode;
  1434. cprocinlinenode:=tprocinlinenode;
  1435. end.
  1436. {
  1437. $Log$
  1438. Revision 1.19 2000-12-17 14:35:12 peter
  1439. * fixed crash with procvar load in tp mode
  1440. Revision 1.18 2000/11/29 00:30:32 florian
  1441. * unused units removed from uses clause
  1442. * some changes for widestrings
  1443. Revision 1.17 2000/11/22 15:12:06 jonas
  1444. * fixed inline-related problems (partially "merges")
  1445. Revision 1.16 2000/11/11 16:14:52 peter
  1446. * fixed crash with settextbuf,ptr
  1447. Revision 1.15 2000/11/06 21:36:25 peter
  1448. * fixed var parameter varstate bug
  1449. Revision 1.14 2000/11/04 14:25:20 florian
  1450. + merged Attila's changes for interfaces, not tested yet
  1451. Revision 1.13 2000/10/31 22:02:47 peter
  1452. * symtable splitted, no real code changes
  1453. Revision 1.12 2000/10/21 18:16:11 florian
  1454. * a lot of changes:
  1455. - basic dyn. array support
  1456. - basic C++ support
  1457. - some work for interfaces done
  1458. ....
  1459. Revision 1.11 2000/10/21 14:35:27 peter
  1460. * readd to many remove p. for tcallnode.is_equal()
  1461. Revision 1.10 2000/10/14 21:52:55 peter
  1462. * fixed memory leaks
  1463. Revision 1.9 2000/10/14 10:14:50 peter
  1464. * moehrendorf oct 2000 rewrite
  1465. Revision 1.8 2000/10/01 19:48:24 peter
  1466. * lot of compile updates for cg11
  1467. Revision 1.7 2000/09/28 19:49:52 florian
  1468. *** empty log message ***
  1469. Revision 1.6 2000/09/27 18:14:31 florian
  1470. * fixed a lot of syntax errors in the n*.pas stuff
  1471. Revision 1.5 2000/09/24 21:15:34 florian
  1472. * some errors fix to get more stuff compilable
  1473. Revision 1.4 2000/09/24 20:17:44 florian
  1474. * more conversion work done
  1475. Revision 1.3 2000/09/24 15:06:19 peter
  1476. * use defines.inc
  1477. Revision 1.2 2000/09/20 21:52:38 florian
  1478. * removed a lot of errors
  1479. Revision 1.1 2000/09/20 20:52:16 florian
  1480. * initial revision
  1481. }