ncal.pas 67 KB

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