ncal.pas 69 KB

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