nld.pas 43 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204
  1. {
  2. Copyright (c) 2000-2002 by Florian Klaempfl
  3. Type checking and register allocation for load/assignment nodes
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit nld;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. node,
  22. {$ifdef state_tracking}
  23. nstate,
  24. {$endif}
  25. symconst,symbase,symtype,symsym,symdef;
  26. type
  27. tloadnode = class(tunarynode)
  28. symtableentry : tsym;
  29. symtableentryderef : tderef;
  30. symtable : tsymtable;
  31. procdef : tprocdef;
  32. procdefderef : tderef;
  33. constructor create(v : tsym;st : tsymtable);virtual;
  34. constructor create_procvar(v : tsym;d:tprocdef;st : tsymtable);virtual;
  35. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  36. procedure ppuwrite(ppufile:tcompilerppufile);override;
  37. procedure buildderefimpl;override;
  38. procedure derefimpl;override;
  39. procedure set_mp(p:tnode);
  40. function is_addr_param_load:boolean;
  41. function _getcopy : tnode;override;
  42. function pass_1 : tnode;override;
  43. function det_resulttype:tnode;override;
  44. procedure mark_write;override;
  45. function docompare(p: tnode): boolean; override;
  46. procedure printnodedata(var t:text);override;
  47. end;
  48. tloadnodeclass = class of tloadnode;
  49. { different assignment types }
  50. tassigntype = (at_normal,at_plus,at_minus,at_star,at_slash);
  51. tassignmentnode = class(tbinarynode)
  52. assigntype : tassigntype;
  53. constructor create(l,r : tnode);virtual;
  54. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  55. procedure ppuwrite(ppufile:tcompilerppufile);override;
  56. function _getcopy : tnode;override;
  57. function pass_1 : tnode;override;
  58. function det_resulttype:tnode;override;
  59. {$ifdef state_tracking}
  60. function track_state_pass(exec_known:boolean):boolean;override;
  61. {$endif state_tracking}
  62. function docompare(p: tnode): boolean; override;
  63. end;
  64. tassignmentnodeclass = class of tassignmentnode;
  65. tarrayconstructorrangenode = class(tbinarynode)
  66. constructor create(l,r : tnode);virtual;
  67. function pass_1 : tnode;override;
  68. function det_resulttype:tnode;override;
  69. end;
  70. tarrayconstructorrangenodeclass = class of tarrayconstructorrangenode;
  71. tarrayconstructornode = class(tbinarynode)
  72. constructor create(l,r : tnode);virtual;
  73. function _getcopy : tnode;override;
  74. function pass_1 : tnode;override;
  75. function det_resulttype:tnode;override;
  76. function docompare(p: tnode): boolean; override;
  77. procedure force_type(tt:ttype);
  78. procedure insert_typeconvs(iscvarargs: boolean);
  79. end;
  80. tarrayconstructornodeclass = class of tarrayconstructornode;
  81. ttypenode = class(tnode)
  82. allowed : boolean;
  83. restype : ttype;
  84. constructor create(t : ttype);virtual;
  85. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  86. procedure ppuwrite(ppufile:tcompilerppufile);override;
  87. procedure buildderefimpl;override;
  88. procedure derefimpl;override;
  89. function pass_1 : tnode;override;
  90. function det_resulttype:tnode;override;
  91. function docompare(p: tnode): boolean; override;
  92. end;
  93. ttypenodeclass = class of ttypenode;
  94. trttinode = class(tnode)
  95. l1,l2 : longint;
  96. rttitype : trttitype;
  97. rttidef : tstoreddef;
  98. rttidefderef : tderef;
  99. constructor create(def:tstoreddef;rt:trttitype);virtual;
  100. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  101. procedure ppuwrite(ppufile:tcompilerppufile);override;
  102. procedure buildderefimpl;override;
  103. procedure derefimpl;override;
  104. function _getcopy : tnode;override;
  105. function pass_1 : tnode;override;
  106. function det_resulttype:tnode;override;
  107. function docompare(p: tnode): boolean; override;
  108. end;
  109. trttinodeclass = class of trttinode;
  110. var
  111. cloadnode : tloadnodeclass;
  112. cassignmentnode : tassignmentnodeclass;
  113. carrayconstructorrangenode : tarrayconstructorrangenodeclass;
  114. carrayconstructornode : tarrayconstructornodeclass;
  115. ctypenode : ttypenodeclass;
  116. crttinode : trttinodeclass;
  117. implementation
  118. uses
  119. cutils,verbose,globtype,globals,systems,
  120. symnot,
  121. defutil,defcmp,
  122. htypechk,pass_1,procinfo,paramgr,
  123. ncon,ninl,ncnv,nmem,ncal,nutils,
  124. cgobj,cgbase
  125. ;
  126. {*****************************************************************************
  127. TLOADNODE
  128. *****************************************************************************}
  129. constructor tloadnode.create(v : tsym;st : tsymtable);
  130. begin
  131. inherited create(loadn,nil);
  132. if not assigned(v) then
  133. internalerror(200108121);
  134. symtableentry:=v;
  135. symtable:=st;
  136. procdef:=nil;
  137. end;
  138. constructor tloadnode.create_procvar(v : tsym;d:tprocdef;st : tsymtable);
  139. begin
  140. inherited create(loadn,nil);
  141. if not assigned(v) then
  142. internalerror(200108121);
  143. symtableentry:=v;
  144. symtable:=st;
  145. procdef:=d;
  146. end;
  147. constructor tloadnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  148. begin
  149. inherited ppuload(t,ppufile);
  150. ppufile.getderef(symtableentryderef);
  151. symtable:=nil;
  152. ppufile.getderef(procdefderef);
  153. end;
  154. procedure tloadnode.ppuwrite(ppufile:tcompilerppufile);
  155. begin
  156. inherited ppuwrite(ppufile);
  157. ppufile.putderef(symtableentryderef);
  158. ppufile.putderef(procdefderef);
  159. end;
  160. procedure tloadnode.buildderefimpl;
  161. begin
  162. inherited buildderefimpl;
  163. symtableentryderef.build(symtableentry);
  164. procdefderef.build(procdef);
  165. end;
  166. procedure tloadnode.derefimpl;
  167. begin
  168. inherited derefimpl;
  169. symtableentry:=tsym(symtableentryderef.resolve);
  170. symtable:=symtableentry.owner;
  171. procdef:=tprocdef(procdefderef.resolve);
  172. end;
  173. procedure tloadnode.set_mp(p:tnode);
  174. begin
  175. { typen nodes should not be set }
  176. if p.nodetype=typen then
  177. internalerror(200301042);
  178. left:=p;
  179. end;
  180. function tloadnode._getcopy : tnode;
  181. var
  182. n : tloadnode;
  183. begin
  184. n:=tloadnode(inherited _getcopy);
  185. n.symtable:=symtable;
  186. n.symtableentry:=symtableentry;
  187. n.procdef:=procdef;
  188. result:=n;
  189. end;
  190. function tloadnode.is_addr_param_load:boolean;
  191. begin
  192. result:=(symtable.symtabletype=parasymtable) and
  193. (symtableentry.typ=paravarsym) and
  194. not(vo_has_local_copy in tparavarsym(symtableentry).varoptions) and
  195. not(nf_load_self_pointer in flags) and
  196. paramanager.push_addr_param(tparavarsym(symtableentry).varspez,tparavarsym(symtableentry).vartype.def,tprocdef(symtable.defowner).proccalloption);
  197. end;
  198. function tloadnode.det_resulttype:tnode;
  199. begin
  200. result:=nil;
  201. case symtableentry.typ of
  202. absolutevarsym :
  203. resulttype:=tabsolutevarsym(symtableentry).vartype;
  204. constsym:
  205. begin
  206. if tconstsym(symtableentry).consttyp=constresourcestring then
  207. resulttype:=cansistringtype
  208. else
  209. internalerror(22799);
  210. end;
  211. globalvarsym,
  212. paravarsym,
  213. localvarsym :
  214. begin
  215. inc(tabstractvarsym(symtableentry).refs);
  216. { Nested variable? The we need to load the framepointer of
  217. the parent procedure }
  218. if assigned(current_procinfo) then
  219. begin
  220. if (symtable.symtabletype in [localsymtable,parasymtable]) and
  221. (symtable.symtablelevel<>current_procinfo.procdef.parast.symtablelevel) then
  222. begin
  223. if assigned(left) then
  224. internalerror(200309289);
  225. left:=cloadparentfpnode.create(tprocdef(symtable.defowner));
  226. { we can't inline the referenced parent procedure }
  227. exclude(tprocdef(symtable.defowner).procoptions,po_inline);
  228. { reference in nested procedures, variable needs to be in memory }
  229. make_not_regable(self);
  230. end;
  231. { static variables referenced in procedures or from finalization,
  232. variable needs to be in memory.
  233. It is too hard and the benefit is too small to detect whether a
  234. variable is only used in the finalization to add support for it (PFV) }
  235. if (symtable.symtabletype=staticsymtable) and
  236. (
  237. (symtable.symtablelevel<>current_procinfo.procdef.localst.symtablelevel) or
  238. (current_procinfo.procdef.proctypeoption=potype_unitfinalize)
  239. ) then
  240. make_not_regable(self);
  241. end;
  242. { fix self type which is declared as voidpointer in the
  243. definition }
  244. if vo_is_self in tabstractvarsym(symtableentry).varoptions then
  245. begin
  246. resulttype.setdef(tprocdef(symtableentry.owner.defowner)._class);
  247. if (po_classmethod in tprocdef(symtableentry.owner.defowner).procoptions) or
  248. (po_staticmethod in tprocdef(symtableentry.owner.defowner).procoptions) then
  249. resulttype.setdef(tclassrefdef.create(resulttype))
  250. else if is_object(resulttype.def) and
  251. (nf_load_self_pointer in flags) then
  252. resulttype.setdef(tpointerdef.create(resulttype));
  253. end
  254. else if vo_is_vmt in tabstractvarsym(symtableentry).varoptions then
  255. begin
  256. resulttype.setdef(tprocdef(symtableentry.owner.defowner)._class);
  257. resulttype.setdef(tclassrefdef.create(resulttype));
  258. end
  259. else
  260. resulttype:=tabstractvarsym(symtableentry).vartype;
  261. end;
  262. typedconstsym :
  263. resulttype:=ttypedconstsym(symtableentry).typedconsttype;
  264. procsym :
  265. begin
  266. { Return the first procdef. In case of overlaoded
  267. procdefs the matching procdef will be choosen
  268. when the expected procvardef is known, see get_information
  269. in htypechk.pas (PFV) }
  270. if not assigned(procdef) then
  271. procdef:=tprocsym(symtableentry).first_procdef;
  272. { the result is a procdef, addrn and proc_to_procvar
  273. typeconvn need this as resulttype so they know
  274. that the address needs to be returned }
  275. resulttype.setdef(procdef);
  276. { process methodpointer }
  277. if assigned(left) then
  278. resulttypepass(left);
  279. end;
  280. labelsym:
  281. resulttype:=voidtype;
  282. else
  283. internalerror(200104141);
  284. end;
  285. end;
  286. procedure Tloadnode.mark_write;
  287. begin
  288. include(flags,nf_write);
  289. end;
  290. function tloadnode.pass_1 : tnode;
  291. begin
  292. result:=nil;
  293. expectloc:=LOC_REFERENCE;
  294. registersint:=0;
  295. registersfpu:=0;
  296. {$ifdef SUPPORT_MMX}
  297. registersmmx:=0;
  298. {$endif SUPPORT_MMX}
  299. if (cs_create_pic in aktmoduleswitches) and
  300. not(symtableentry.typ in [paravarsym,localvarsym]) then
  301. include(current_procinfo.flags,pi_needs_got);
  302. case symtableentry.typ of
  303. absolutevarsym :
  304. ;
  305. constsym:
  306. begin
  307. if tconstsym(symtableentry).consttyp=constresourcestring then
  308. expectloc:=LOC_CREFERENCE;
  309. end;
  310. globalvarsym,
  311. localvarsym,
  312. paravarsym :
  313. begin
  314. if assigned(left) then
  315. firstpass(left);
  316. if not is_addr_param_load and
  317. tabstractvarsym(symtableentry).is_regvar then
  318. begin
  319. case tabstractvarsym(symtableentry).varregable of
  320. vr_intreg :
  321. expectloc:=LOC_CREGISTER;
  322. vr_fpureg :
  323. expectloc:=LOC_CFPUREGISTER;
  324. vr_mmreg :
  325. expectloc:=LOC_CMMREGISTER;
  326. end
  327. end
  328. else
  329. if (tabstractvarsym(symtableentry).varspez=vs_const) then
  330. expectloc:=LOC_CREFERENCE;
  331. { we need a register for call by reference parameters }
  332. if paramanager.push_addr_param(tabstractvarsym(symtableentry).varspez,tabstractvarsym(symtableentry).vartype.def,pocall_default) then
  333. registersint:=1;
  334. if ([vo_is_thread_var,vo_is_dll_var]*tabstractvarsym(symtableentry).varoptions)<>[] then
  335. registersint:=1;
  336. if (target_info.system=system_powerpc_darwin) and
  337. ([vo_is_dll_var,vo_is_external] * tabstractvarsym(symtableentry).varoptions <> []) then
  338. include(current_procinfo.flags,pi_needs_got);
  339. { call to get address of threadvar }
  340. if (vo_is_thread_var in tabstractvarsym(symtableentry).varoptions) then
  341. include(current_procinfo.flags,pi_do_call);
  342. if nf_write in flags then
  343. Tabstractvarsym(symtableentry).trigger_notifications(vn_onwrite)
  344. else
  345. Tabstractvarsym(symtableentry).trigger_notifications(vn_onread);
  346. { count variable references }
  347. if cg.t_times>1 then
  348. inc(tabstractvarsym(symtableentry).refs,cg.t_times-1);
  349. end;
  350. typedconstsym :
  351. ;
  352. procsym :
  353. begin
  354. { method pointer ? }
  355. if assigned(left) then
  356. begin
  357. expectloc:=LOC_CREFERENCE;
  358. firstpass(left);
  359. registersint:=max(registersint,left.registersint);
  360. registersfpu:=max(registersfpu,left.registersfpu);
  361. {$ifdef SUPPORT_MMX}
  362. registersmmx:=max(registersmmx,left.registersmmx);
  363. {$endif SUPPORT_MMX}
  364. end;
  365. end;
  366. labelsym :
  367. ;
  368. else
  369. internalerror(200104143);
  370. end;
  371. end;
  372. function tloadnode.docompare(p: tnode): boolean;
  373. begin
  374. docompare :=
  375. inherited docompare(p) and
  376. (symtableentry = tloadnode(p).symtableentry) and
  377. (procdef = tloadnode(p).procdef) and
  378. (symtable = tloadnode(p).symtable);
  379. end;
  380. procedure Tloadnode.printnodedata(var t:text);
  381. begin
  382. inherited printnodedata(t);
  383. write(t,printnodeindention,'symbol = ',symtableentry.name);
  384. if symtableentry.typ=procsym then
  385. write(t,printnodeindention,'procdef = ',procdef.mangledname);
  386. writeln(t,'');
  387. end;
  388. {*****************************************************************************
  389. TASSIGNMENTNODE
  390. *****************************************************************************}
  391. constructor tassignmentnode.create(l,r : tnode);
  392. begin
  393. inherited create(assignn,l,r);
  394. l.mark_write;
  395. assigntype:=at_normal;
  396. end;
  397. constructor tassignmentnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  398. begin
  399. inherited ppuload(t,ppufile);
  400. assigntype:=tassigntype(ppufile.getbyte);
  401. end;
  402. procedure tassignmentnode.ppuwrite(ppufile:tcompilerppufile);
  403. begin
  404. inherited ppuwrite(ppufile);
  405. ppufile.putbyte(byte(assigntype));
  406. end;
  407. function tassignmentnode._getcopy : tnode;
  408. var
  409. n : tassignmentnode;
  410. begin
  411. n:=tassignmentnode(inherited _getcopy);
  412. n.assigntype:=assigntype;
  413. result:=n;
  414. end;
  415. function tassignmentnode.det_resulttype:tnode;
  416. var
  417. hp : tnode;
  418. useshelper : boolean;
  419. begin
  420. result:=nil;
  421. resulttype:=voidtype;
  422. { must be made unique }
  423. set_unique(left);
  424. resulttypepass(left);
  425. if is_ansistring(left.resulttype.def) then
  426. begin
  427. { fold <ansistring>:=<ansistring>+<char|shortstring|ansistring> }
  428. if (right.nodetype=addn) and
  429. left.isequal(tbinarynode(right).left) and
  430. { don't fold multiple concatenations else we could get trouble
  431. with multiple uses of s
  432. }
  433. (tbinarynode(right).left.nodetype<>addn) and
  434. (tbinarynode(right).right.nodetype<>addn) then
  435. begin
  436. { don't do a resulttypepass(right), since then the addnode }
  437. { may insert typeconversions that make this optimization }
  438. { opportunity quite difficult to detect (JM) }
  439. resulttypepass(tbinarynode(right).left);
  440. resulttypepass(tbinarynode(right).right);
  441. if (tbinarynode(right).right.nodetype=stringconstn) or
  442. is_char(tbinarynode(right).right.resulttype.def) or
  443. is_shortstring(tbinarynode(right).right.resulttype.def) or
  444. is_ansistring(tbinarynode(right).right.resulttype.def) then
  445. begin
  446. { remove property flag so it'll not trigger an error }
  447. exclude(left.flags,nf_isproperty);
  448. { generate call to helper }
  449. hp:=ccallparanode.create(tbinarynode(right).right,
  450. ccallparanode.create(left,nil));
  451. if is_char(tbinarynode(right).right.resulttype.def) then
  452. result:=ccallnode.createintern('fpc_'+Tstringdef(left.resulttype.def).stringtypname+'_append_char',hp)
  453. else if is_shortstring(tbinarynode(right).right.resulttype.def) then
  454. result:=ccallnode.createintern('fpc_'+Tstringdef(left.resulttype.def).stringtypname+'_append_shortstring',hp)
  455. else
  456. result:=ccallnode.createintern('fpc_'+Tstringdef(left.resulttype.def).stringtypname+'_append_ansistring',hp);
  457. tbinarynode(right).right:=nil;
  458. left:=nil;
  459. exit;
  460. end;
  461. end;
  462. end
  463. else
  464. if is_shortstring(left.resulttype.def) then
  465. begin
  466. { fold <shortstring>:=<shortstring>+<shortstring>,
  467. <shortstring>+<char> is handled by an optimized node }
  468. if (right.nodetype=addn) and
  469. left.isequal(tbinarynode(right).left) and
  470. { don't fold multiple concatenations else we could get trouble
  471. with multiple uses of s }
  472. (tbinarynode(right).left.nodetype<>addn) and
  473. (tbinarynode(right).right.nodetype<>addn) then
  474. begin
  475. { don't do a resulttypepass(right), since then the addnode }
  476. { may insert typeconversions that make this optimization }
  477. { opportunity quite difficult to detect (JM) }
  478. resulttypepass(tbinarynode(right).left);
  479. resulttypepass(tbinarynode(right).right);
  480. if is_shortstring(tbinarynode(right).right.resulttype.def) then
  481. begin
  482. { remove property flag so it'll not trigger an error }
  483. exclude(left.flags,nf_isproperty);
  484. { generate call to helper }
  485. hp:=ccallparanode.create(tbinarynode(right).right,
  486. ccallparanode.create(left,nil));
  487. if is_shortstring(tbinarynode(right).right.resulttype.def) then
  488. result:=ccallnode.createintern('fpc_shortstr_append_shortstr',hp);
  489. tbinarynode(right).right:=nil;
  490. left:=nil;
  491. exit;
  492. end;
  493. end;
  494. end;
  495. resulttypepass(right);
  496. set_varstate(right,vs_read,[vsf_must_be_valid]);
  497. set_varstate(left,vs_written,[]);
  498. if codegenerror then
  499. exit;
  500. { tp procvar support, when we don't expect a procvar
  501. then we need to call the procvar }
  502. if (left.resulttype.def.deftype<>procvardef) then
  503. maybe_call_procvar(right,true);
  504. { assignments to formaldefs and open arrays aren't allowed }
  505. if (left.resulttype.def.deftype=formaldef) or
  506. is_open_array(left.resulttype.def) then
  507. CGMessage(type_e_operator_not_allowed);
  508. { test if node can be assigned, properties are allowed }
  509. valid_for_assignment(left,true);
  510. { assigning nil to a dynamic array clears the array }
  511. if is_dynamic_array(left.resulttype.def) and
  512. (right.nodetype=niln) then
  513. begin
  514. hp:=ccallparanode.create(caddrnode.create_internal
  515. (crttinode.create(tstoreddef(left.resulttype.def),initrtti)),
  516. ccallparanode.create(ctypeconvnode.create_internal(left,voidpointertype),nil));
  517. result := ccallnode.createintern('fpc_dynarray_clear',hp);
  518. left:=nil;
  519. exit;
  520. end;
  521. { shortstring helpers can do the conversion directly,
  522. so treat them separatly }
  523. if (is_shortstring(left.resulttype.def)) then
  524. begin
  525. { insert typeconv, except for chars that are handled in
  526. secondpass and except for ansi/wide string that can
  527. be converted immediatly }
  528. if not(is_char(right.resulttype.def) or
  529. (right.resulttype.def.deftype=stringdef)) then
  530. inserttypeconv(right,left.resulttype);
  531. if right.resulttype.def.deftype=stringdef then
  532. begin
  533. useshelper:=true;
  534. { convert constant strings to shortstrings. But
  535. skip empty constant strings, that will be handled
  536. in secondpass }
  537. if (right.nodetype=stringconstn) then
  538. begin
  539. { verify if range fits within shortstring }
  540. { just emit a warning, delphi gives an }
  541. { error, only if the type definition of }
  542. { of the string is less < 255 characters }
  543. if not is_open_string(left.resulttype.def) and
  544. (tstringconstnode(right).len > tstringdef(left.resulttype.def).len) then
  545. cgmessage(type_w_string_too_long);
  546. inserttypeconv(right,left.resulttype);
  547. if (tstringconstnode(right).len=0) then
  548. useshelper:=false;
  549. end;
  550. { rest is done in pass 1 (JM) }
  551. if useshelper then
  552. exit;
  553. end
  554. end
  555. else
  556. begin
  557. { check if the assignment may cause a range check error }
  558. check_ranges(fileinfo,right,left.resulttype.def);
  559. inserttypeconv(right,left.resulttype);
  560. end;
  561. { call helpers for interface }
  562. if is_interfacecom(left.resulttype.def) then
  563. begin
  564. hp:=ccallparanode.create(ctypeconvnode.create_internal
  565. (right,voidpointertype),
  566. ccallparanode.create(ctypeconvnode.create_internal
  567. (left,voidpointertype),nil));
  568. result:=ccallnode.createintern('fpc_intf_assign',hp);
  569. left:=nil;
  570. right:=nil;
  571. exit;
  572. end;
  573. { call helpers for variant, they can contain non ref. counted types like
  574. vararrays which must be really copied }
  575. if left.resulttype.def.deftype=variantdef then
  576. begin
  577. hp:=ccallparanode.create(ctypeconvnode.create_internal(
  578. caddrnode.create_internal(right),voidpointertype),
  579. ccallparanode.create(ctypeconvnode.create_internal(
  580. caddrnode.create_internal(left),voidpointertype),
  581. nil));
  582. result:=ccallnode.createintern('fpc_variant_copy',hp);
  583. left:=nil;
  584. right:=nil;
  585. exit;
  586. end;
  587. { check if local proc/func is assigned to procvar }
  588. if right.resulttype.def.deftype=procvardef then
  589. test_local_to_procvar(tprocvardef(right.resulttype.def),left.resulttype.def);
  590. end;
  591. function tassignmentnode.pass_1 : tnode;
  592. var
  593. hp: tnode;
  594. begin
  595. result:=nil;
  596. expectloc:=LOC_VOID;
  597. firstpass(left);
  598. firstpass(right);
  599. { assignment to refcounted variable -> inc/decref }
  600. if (not is_class(left.resulttype.def) and
  601. left.resulttype.def.needs_inittable) then
  602. include(current_procinfo.flags,pi_do_call);
  603. if codegenerror then
  604. exit;
  605. if (is_shortstring(left.resulttype.def)) then
  606. begin
  607. if right.resulttype.def.deftype=stringdef then
  608. begin
  609. if (right.nodetype<>stringconstn) or
  610. (tstringconstnode(right).len<>0) then
  611. begin
  612. if (cs_opt_level1 in aktoptimizerswitches) and
  613. (right.nodetype in [calln,blockn]) and
  614. (left.nodetype = temprefn) and
  615. is_shortstring(right.resulttype.def) and
  616. not is_open_string(left.resulttype.def) and
  617. (tstringdef(left.resulttype.def).len = 255) then
  618. begin
  619. { the blocknode case is handled in pass_2 at the temp }
  620. { reference level (mainly for callparatemp) (JM) }
  621. if (right.nodetype = calln) then
  622. begin
  623. tcallnode(right).funcretnode := left;
  624. result := right;
  625. end
  626. else
  627. exit;
  628. end
  629. else
  630. begin
  631. hp:=ccallparanode.create
  632. (right,
  633. ccallparanode.create(cinlinenode.create
  634. (in_high_x,false,left.getcopy),nil));
  635. result:=ccallnode.createinternreturn('fpc_'+tstringdef(right.resulttype.def).stringtypname+'_to_shortstr',hp,left);
  636. firstpass(result);
  637. end;
  638. left:=nil;
  639. right:=nil;
  640. exit;
  641. end;
  642. end;
  643. end;
  644. if (cs_opt_level1 in aktoptimizerswitches) and
  645. (right.nodetype = calln) and
  646. { left must be a temp, since otherwise as soon as you modify the }
  647. { result, the current left node is modified and that one may }
  648. { still be an argument to the function or even accessed in the }
  649. { function }
  650. (((left.nodetype = temprefn) and
  651. paramanager.ret_in_param(right.resulttype.def,
  652. tcallnode(right).procdefinition.proccalloption)) or
  653. { there's special support for ansi/widestrings in the callnode }
  654. is_ansistring(right.resulttype.def) or
  655. is_widestring(right.resulttype.def)) then
  656. begin
  657. tcallnode(right).funcretnode := left;
  658. result := right;
  659. left := nil;
  660. right := nil;
  661. exit;
  662. end;
  663. registersint:=left.registersint+right.registersint;
  664. registersfpu:=max(left.registersfpu,right.registersfpu);
  665. {$ifdef SUPPORT_MMX}
  666. registersmmx:=max(left.registersmmx,right.registersmmx);
  667. {$endif SUPPORT_MMX}
  668. end;
  669. function tassignmentnode.docompare(p: tnode): boolean;
  670. begin
  671. docompare :=
  672. inherited docompare(p) and
  673. (assigntype = tassignmentnode(p).assigntype);
  674. end;
  675. {$ifdef state_tracking}
  676. function Tassignmentnode.track_state_pass(exec_known:boolean):boolean;
  677. var se:Tstate_entry;
  678. begin
  679. track_state_pass:=false;
  680. if exec_known then
  681. begin
  682. track_state_pass:=right.track_state_pass(exec_known);
  683. {Force a new resulttype pass.}
  684. right.resulttype.def:=nil;
  685. do_resulttypepass(right);
  686. resulttypepass(right);
  687. aktstate.store_fact(left.getcopy,right.getcopy);
  688. end
  689. else
  690. aktstate.delete_fact(left);
  691. end;
  692. {$endif}
  693. {*****************************************************************************
  694. TARRAYCONSTRUCTORRANGENODE
  695. *****************************************************************************}
  696. constructor tarrayconstructorrangenode.create(l,r : tnode);
  697. begin
  698. inherited create(arrayconstructorrangen,l,r);
  699. end;
  700. function tarrayconstructorrangenode.det_resulttype:tnode;
  701. begin
  702. result:=nil;
  703. resulttypepass(left);
  704. resulttypepass(right);
  705. set_varstate(left,vs_read,[vsf_must_be_valid]);
  706. set_varstate(right,vs_read,[vsf_must_be_valid]);
  707. if codegenerror then
  708. exit;
  709. resulttype:=left.resulttype;
  710. end;
  711. function tarrayconstructorrangenode.pass_1 : tnode;
  712. begin
  713. firstpass(left);
  714. firstpass(right);
  715. expectloc:=LOC_CREFERENCE;
  716. calcregisters(self,0,0,0);
  717. result:=nil;
  718. end;
  719. {****************************************************************************
  720. TARRAYCONSTRUCTORNODE
  721. *****************************************************************************}
  722. constructor tarrayconstructornode.create(l,r : tnode);
  723. begin
  724. inherited create(arrayconstructorn,l,r);
  725. end;
  726. function tarrayconstructornode._getcopy : tnode;
  727. var
  728. n : tarrayconstructornode;
  729. begin
  730. n:=tarrayconstructornode(inherited _getcopy);
  731. result:=n;
  732. end;
  733. function tarrayconstructornode.det_resulttype:tnode;
  734. var
  735. htype : ttype;
  736. hp : tarrayconstructornode;
  737. len : longint;
  738. varia : boolean;
  739. begin
  740. result:=nil;
  741. { are we allowing array constructor? Then convert it to a set }
  742. if not allow_array_constructor then
  743. begin
  744. hp:=tarrayconstructornode(getcopy);
  745. arrayconstructor_to_set(tnode(hp));
  746. result:=hp;
  747. exit;
  748. end;
  749. { only pass left tree, right tree contains next construct if any }
  750. htype.reset;
  751. len:=0;
  752. varia:=false;
  753. if assigned(left) then
  754. begin
  755. hp:=self;
  756. while assigned(hp) do
  757. begin
  758. resulttypepass(hp.left);
  759. set_varstate(hp.left,vs_read,[vsf_must_be_valid]);
  760. if (htype.def=nil) then
  761. htype:=hp.left.resulttype
  762. else
  763. begin
  764. if ((nf_novariaallowed in flags) or (not varia)) and
  765. (not equal_defs(htype.def,hp.left.resulttype.def)) then
  766. begin
  767. varia:=true;
  768. end;
  769. end;
  770. inc(len);
  771. hp:=tarrayconstructornode(hp.right);
  772. end;
  773. end;
  774. { Set the type of empty or varia arrays to void. Also
  775. do this if the type is array of const/open array
  776. because those can't be used with setelementtype }
  777. if not assigned(htype.def) or
  778. varia or
  779. is_array_of_const(htype.def) or
  780. is_open_array(htype.def) then
  781. htype:=voidtype;
  782. resulttype.setdef(tarraydef.create(0,len-1,s32inttype));
  783. tarraydef(resulttype.def).setelementtype(htype);
  784. tarraydef(resulttype.def).IsConstructor:=true;
  785. tarraydef(resulttype.def).IsVariant:=varia;
  786. end;
  787. procedure tarrayconstructornode.force_type(tt:ttype);
  788. var
  789. hp : tarrayconstructornode;
  790. begin
  791. tarraydef(resulttype.def).setelementtype(tt);
  792. tarraydef(resulttype.def).IsConstructor:=true;
  793. tarraydef(resulttype.def).IsVariant:=false;
  794. if assigned(left) then
  795. begin
  796. hp:=self;
  797. while assigned(hp) do
  798. begin
  799. inserttypeconv(hp.left,tt);
  800. hp:=tarrayconstructornode(hp.right);
  801. end;
  802. end;
  803. end;
  804. procedure tarrayconstructornode.insert_typeconvs(iscvarargs: boolean);
  805. var
  806. hp : tarrayconstructornode;
  807. dovariant : boolean;
  808. begin
  809. if (iscvarargs) then
  810. include(flags,nf_cvarargs);
  811. dovariant:=(nf_forcevaria in flags) or tarraydef(resulttype.def).isvariant or iscvarargs;
  812. { only pass left tree, right tree contains next construct if any }
  813. if assigned(left) then
  814. begin
  815. hp:=self;
  816. while assigned(hp) do
  817. begin
  818. resulttypepass(hp.left);
  819. { Insert typeconvs for array of const }
  820. if dovariant then
  821. begin
  822. if not(iscvarargs) and
  823. (hp.left.nodetype=stringconstn) then
  824. hp.left:=ctypeconvnode.create_internal(hp.left,cansistringtype)
  825. else
  826. case hp.left.resulttype.def.deftype of
  827. enumdef :
  828. hp.left:=ctypeconvnode.create_internal(hp.left,s32inttype);
  829. arraydef :
  830. begin
  831. if is_chararray(hp.left.resulttype.def) then
  832. hp.left:=ctypeconvnode.create_internal(hp.left,charpointertype)
  833. else
  834. if is_widechararray(hp.left.resulttype.def) then
  835. hp.left:=ctypeconvnode.create_internal(hp.left,widecharpointertype)
  836. else
  837. CGMessagePos1(hp.left.fileinfo,type_e_wrong_type_in_array_constructor,hp.left.resulttype.def.typename);
  838. end;
  839. orddef :
  840. begin
  841. if is_integer(hp.left.resulttype.def) and
  842. not(is_64bitint(hp.left.resulttype.def)) then
  843. hp.left:=ctypeconvnode.create(hp.left,s32inttype)
  844. else if is_void(hp.left.resulttype.def) then
  845. CGMessagePos1(hp.left.fileinfo,type_e_wrong_type_in_array_constructor,hp.left.resulttype.def.typename)
  846. else if iscvarargs and
  847. is_currency(hp.left.resulttype.def) then
  848. hp.left:=ctypeconvnode.create(hp.left,s64floattype);
  849. end;
  850. floatdef :
  851. if not(iscvarargs) then
  852. begin
  853. if not(is_currency(hp.left.resulttype.def)) then
  854. hp.left:=ctypeconvnode.create(hp.left,pbestrealtype^);
  855. end
  856. else
  857. begin
  858. if is_constrealnode(hp.left) and
  859. not(nf_explicit in hp.left.flags) then
  860. MessagePos(hp.left.fileinfo,type_w_double_c_varargs);
  861. if (tfloatdef(hp.left.resulttype.def).typ in [{$ifndef x86_64}s32real,{$endif}s64currency]) or
  862. (is_constrealnode(hp.left) and
  863. not(nf_explicit in hp.left.flags)) then
  864. hp.left:=ctypeconvnode.create(hp.left,s64floattype);
  865. end;
  866. procvardef :
  867. hp.left:=ctypeconvnode.create(hp.left,voidpointertype);
  868. stringdef:
  869. if iscvarargs then
  870. hp.left:=ctypeconvnode.create(hp.left,charpointertype);
  871. variantdef:
  872. if iscvarargs then
  873. CGMessagePos1(hp.left.fileinfo,type_e_wrong_type_in_array_constructor,hp.left.resulttype.def.typename);
  874. pointerdef:
  875. ;
  876. classrefdef:
  877. if iscvarargs then
  878. hp.left:=ctypeconvnode.create(hp.left,voidpointertype);
  879. objectdef :
  880. if iscvarargs or
  881. is_object(hp.left.resulttype.def) then
  882. CGMessagePos1(hp.left.fileinfo,type_e_wrong_type_in_array_constructor,hp.left.resulttype.def.typename);
  883. else
  884. CGMessagePos1(hp.left.fileinfo,type_e_wrong_type_in_array_constructor,hp.left.resulttype.def.typename);
  885. end;
  886. end;
  887. resulttypepass(hp.left);
  888. hp:=tarrayconstructornode(hp.right);
  889. end;
  890. end;
  891. end;
  892. function tarrayconstructornode.pass_1 : tnode;
  893. var
  894. hp : tarrayconstructornode;
  895. do_variant:boolean;
  896. begin
  897. do_variant:=(nf_forcevaria in flags) or tarraydef(resulttype.def).isvariant;
  898. result:=nil;
  899. { Insert required type convs, this must be
  900. done in pass 1, because the call must be
  901. resulttypepassed already }
  902. if assigned(left) then
  903. begin
  904. { in case of C varargs, insert_typeconvs has already been called }
  905. if not(nf_cvarargs in flags) then
  906. insert_typeconvs(false);
  907. { call firstpass for all nodes }
  908. hp:=self;
  909. while assigned(hp) do
  910. begin
  911. if hp.left<>nil then
  912. begin
  913. {This check is pessimistic; a call will happen depending
  914. on the location in which the elements will be found in
  915. pass 2.}
  916. if not do_variant then
  917. include(current_procinfo.flags,pi_do_call);
  918. firstpass(hp.left);
  919. end;
  920. hp:=tarrayconstructornode(hp.right);
  921. end;
  922. end;
  923. expectloc:=LOC_CREFERENCE;
  924. calcregisters(self,0,0,0);
  925. end;
  926. function tarrayconstructornode.docompare(p: tnode): boolean;
  927. begin
  928. docompare:=inherited docompare(p);
  929. end;
  930. {*****************************************************************************
  931. TTYPENODE
  932. *****************************************************************************}
  933. constructor ttypenode.create(t : ttype);
  934. begin
  935. inherited create(typen);
  936. restype:=t;
  937. allowed:=false;
  938. end;
  939. constructor ttypenode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  940. begin
  941. inherited ppuload(t,ppufile);
  942. ppufile.gettype(restype);
  943. allowed:=boolean(ppufile.getbyte);
  944. end;
  945. procedure ttypenode.ppuwrite(ppufile:tcompilerppufile);
  946. begin
  947. inherited ppuwrite(ppufile);
  948. ppufile.puttype(restype);
  949. ppufile.putbyte(byte(allowed));
  950. end;
  951. procedure ttypenode.buildderefimpl;
  952. begin
  953. inherited buildderefimpl;
  954. restype.buildderef;
  955. end;
  956. procedure ttypenode.derefimpl;
  957. begin
  958. inherited derefimpl;
  959. restype.resolve;
  960. end;
  961. function ttypenode.det_resulttype:tnode;
  962. begin
  963. result:=nil;
  964. resulttype:=restype;
  965. { check if it's valid }
  966. if restype.def.deftype = errordef then
  967. CGMessage(parser_e_illegal_expression);
  968. end;
  969. function ttypenode.pass_1 : tnode;
  970. begin
  971. result:=nil;
  972. expectloc:=LOC_VOID;
  973. { a typenode can't generate code, so we give here
  974. an error. Else it'll be an abstract error in pass_2.
  975. Only when the allowed flag is set we don't generate
  976. an error }
  977. if not allowed then
  978. Message(parser_e_no_type_not_allowed_here);
  979. end;
  980. function ttypenode.docompare(p: tnode): boolean;
  981. begin
  982. docompare :=
  983. inherited docompare(p);
  984. end;
  985. {*****************************************************************************
  986. TRTTINODE
  987. *****************************************************************************}
  988. constructor trttinode.create(def:tstoreddef;rt:trttitype);
  989. begin
  990. inherited create(rttin);
  991. rttidef:=def;
  992. rttitype:=rt;
  993. end;
  994. constructor trttinode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  995. begin
  996. inherited ppuload(t,ppufile);
  997. ppufile.getderef(rttidefderef);
  998. rttitype:=trttitype(ppufile.getbyte);
  999. end;
  1000. procedure trttinode.ppuwrite(ppufile:tcompilerppufile);
  1001. begin
  1002. inherited ppuwrite(ppufile);
  1003. ppufile.putderef(rttidefderef);
  1004. ppufile.putbyte(byte(rttitype));
  1005. end;
  1006. procedure trttinode.buildderefimpl;
  1007. begin
  1008. inherited buildderefimpl;
  1009. rttidefderef.build(rttidef);
  1010. end;
  1011. procedure trttinode.derefimpl;
  1012. begin
  1013. inherited derefimpl;
  1014. rttidef:=tstoreddef(rttidefderef.resolve);
  1015. end;
  1016. function trttinode._getcopy : tnode;
  1017. var
  1018. n : trttinode;
  1019. begin
  1020. n:=trttinode(inherited _getcopy);
  1021. n.rttidef:=rttidef;
  1022. n.rttitype:=rttitype;
  1023. result:=n;
  1024. end;
  1025. function trttinode.det_resulttype:tnode;
  1026. begin
  1027. { rtti information will be returned as a void pointer }
  1028. result:=nil;
  1029. resulttype:=voidpointertype;
  1030. end;
  1031. function trttinode.pass_1 : tnode;
  1032. begin
  1033. result:=nil;
  1034. expectloc:=LOC_CREFERENCE;
  1035. end;
  1036. function trttinode.docompare(p: tnode): boolean;
  1037. begin
  1038. docompare :=
  1039. inherited docompare(p) and
  1040. (rttidef = trttinode(p).rttidef) and
  1041. (rttitype = trttinode(p).rttitype);
  1042. end;
  1043. begin
  1044. cloadnode:=tloadnode;
  1045. cassignmentnode:=tassignmentnode;
  1046. carrayconstructorrangenode:=tarrayconstructorrangenode;
  1047. carrayconstructornode:=tarrayconstructornode;
  1048. ctypenode:=ttypenode;
  1049. crttinode:=trttinode;
  1050. end.