nld.pas 43 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205
  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. include(tarraydef(resulttype.def).arrayoptions,ado_IsConstructor);
  785. if varia then
  786. include(tarraydef(resulttype.def).arrayoptions,ado_IsVariant);
  787. end;
  788. procedure tarrayconstructornode.force_type(tt:ttype);
  789. var
  790. hp : tarrayconstructornode;
  791. begin
  792. tarraydef(resulttype.def).setelementtype(tt);
  793. include(tarraydef(resulttype.def).arrayoptions,ado_IsConstructor);
  794. exclude(tarraydef(resulttype.def).arrayoptions,ado_IsVariant);
  795. if assigned(left) then
  796. begin
  797. hp:=self;
  798. while assigned(hp) do
  799. begin
  800. inserttypeconv(hp.left,tt);
  801. hp:=tarrayconstructornode(hp.right);
  802. end;
  803. end;
  804. end;
  805. procedure tarrayconstructornode.insert_typeconvs(iscvarargs: boolean);
  806. var
  807. hp : tarrayconstructornode;
  808. dovariant : boolean;
  809. begin
  810. if (iscvarargs) then
  811. include(flags,nf_cvarargs);
  812. dovariant:=(nf_forcevaria in flags) or (ado_isvariant in tarraydef(resulttype.def).arrayoptions) or iscvarargs;
  813. { only pass left tree, right tree contains next construct if any }
  814. if assigned(left) then
  815. begin
  816. hp:=self;
  817. while assigned(hp) do
  818. begin
  819. resulttypepass(hp.left);
  820. { Insert typeconvs for array of const }
  821. if dovariant then
  822. begin
  823. if not(iscvarargs) and
  824. (hp.left.nodetype=stringconstn) then
  825. hp.left:=ctypeconvnode.create_internal(hp.left,cansistringtype)
  826. else
  827. case hp.left.resulttype.def.deftype of
  828. enumdef :
  829. hp.left:=ctypeconvnode.create_internal(hp.left,s32inttype);
  830. arraydef :
  831. begin
  832. if is_chararray(hp.left.resulttype.def) then
  833. hp.left:=ctypeconvnode.create_internal(hp.left,charpointertype)
  834. else
  835. if is_widechararray(hp.left.resulttype.def) then
  836. hp.left:=ctypeconvnode.create_internal(hp.left,widecharpointertype)
  837. else
  838. CGMessagePos1(hp.left.fileinfo,type_e_wrong_type_in_array_constructor,hp.left.resulttype.def.typename);
  839. end;
  840. orddef :
  841. begin
  842. if is_integer(hp.left.resulttype.def) and
  843. not(is_64bitint(hp.left.resulttype.def)) then
  844. hp.left:=ctypeconvnode.create(hp.left,s32inttype)
  845. else if is_void(hp.left.resulttype.def) then
  846. CGMessagePos1(hp.left.fileinfo,type_e_wrong_type_in_array_constructor,hp.left.resulttype.def.typename)
  847. else if iscvarargs and
  848. is_currency(hp.left.resulttype.def) then
  849. hp.left:=ctypeconvnode.create(hp.left,s64floattype);
  850. end;
  851. floatdef :
  852. if not(iscvarargs) then
  853. begin
  854. if not(is_currency(hp.left.resulttype.def)) then
  855. hp.left:=ctypeconvnode.create(hp.left,pbestrealtype^);
  856. end
  857. else
  858. begin
  859. if is_constrealnode(hp.left) and
  860. not(nf_explicit in hp.left.flags) then
  861. MessagePos(hp.left.fileinfo,type_w_double_c_varargs);
  862. if (tfloatdef(hp.left.resulttype.def).typ in [{$ifndef x86_64}s32real,{$endif}s64currency]) or
  863. (is_constrealnode(hp.left) and
  864. not(nf_explicit in hp.left.flags)) then
  865. hp.left:=ctypeconvnode.create(hp.left,s64floattype);
  866. end;
  867. procvardef :
  868. hp.left:=ctypeconvnode.create(hp.left,voidpointertype);
  869. stringdef:
  870. if iscvarargs then
  871. hp.left:=ctypeconvnode.create(hp.left,charpointertype);
  872. variantdef:
  873. if iscvarargs then
  874. CGMessagePos1(hp.left.fileinfo,type_e_wrong_type_in_array_constructor,hp.left.resulttype.def.typename);
  875. pointerdef:
  876. ;
  877. classrefdef:
  878. if iscvarargs then
  879. hp.left:=ctypeconvnode.create(hp.left,voidpointertype);
  880. objectdef :
  881. if iscvarargs or
  882. is_object(hp.left.resulttype.def) then
  883. CGMessagePos1(hp.left.fileinfo,type_e_wrong_type_in_array_constructor,hp.left.resulttype.def.typename);
  884. else
  885. CGMessagePos1(hp.left.fileinfo,type_e_wrong_type_in_array_constructor,hp.left.resulttype.def.typename);
  886. end;
  887. end;
  888. resulttypepass(hp.left);
  889. hp:=tarrayconstructornode(hp.right);
  890. end;
  891. end;
  892. end;
  893. function tarrayconstructornode.pass_1 : tnode;
  894. var
  895. hp : tarrayconstructornode;
  896. do_variant:boolean;
  897. begin
  898. do_variant:=(nf_forcevaria in flags) or (ado_isvariant in tarraydef(resulttype.def).arrayoptions);
  899. result:=nil;
  900. { Insert required type convs, this must be
  901. done in pass 1, because the call must be
  902. resulttypepassed already }
  903. if assigned(left) then
  904. begin
  905. { in case of C varargs, insert_typeconvs has already been called }
  906. if not(nf_cvarargs in flags) then
  907. insert_typeconvs(false);
  908. { call firstpass for all nodes }
  909. hp:=self;
  910. while assigned(hp) do
  911. begin
  912. if hp.left<>nil then
  913. begin
  914. {This check is pessimistic; a call will happen depending
  915. on the location in which the elements will be found in
  916. pass 2.}
  917. if not do_variant then
  918. include(current_procinfo.flags,pi_do_call);
  919. firstpass(hp.left);
  920. end;
  921. hp:=tarrayconstructornode(hp.right);
  922. end;
  923. end;
  924. expectloc:=LOC_CREFERENCE;
  925. calcregisters(self,0,0,0);
  926. end;
  927. function tarrayconstructornode.docompare(p: tnode): boolean;
  928. begin
  929. docompare:=inherited docompare(p);
  930. end;
  931. {*****************************************************************************
  932. TTYPENODE
  933. *****************************************************************************}
  934. constructor ttypenode.create(t : ttype);
  935. begin
  936. inherited create(typen);
  937. restype:=t;
  938. allowed:=false;
  939. end;
  940. constructor ttypenode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  941. begin
  942. inherited ppuload(t,ppufile);
  943. ppufile.gettype(restype);
  944. allowed:=boolean(ppufile.getbyte);
  945. end;
  946. procedure ttypenode.ppuwrite(ppufile:tcompilerppufile);
  947. begin
  948. inherited ppuwrite(ppufile);
  949. ppufile.puttype(restype);
  950. ppufile.putbyte(byte(allowed));
  951. end;
  952. procedure ttypenode.buildderefimpl;
  953. begin
  954. inherited buildderefimpl;
  955. restype.buildderef;
  956. end;
  957. procedure ttypenode.derefimpl;
  958. begin
  959. inherited derefimpl;
  960. restype.resolve;
  961. end;
  962. function ttypenode.det_resulttype:tnode;
  963. begin
  964. result:=nil;
  965. resulttype:=restype;
  966. { check if it's valid }
  967. if restype.def.deftype = errordef then
  968. CGMessage(parser_e_illegal_expression);
  969. end;
  970. function ttypenode.pass_1 : tnode;
  971. begin
  972. result:=nil;
  973. expectloc:=LOC_VOID;
  974. { a typenode can't generate code, so we give here
  975. an error. Else it'll be an abstract error in pass_2.
  976. Only when the allowed flag is set we don't generate
  977. an error }
  978. if not allowed then
  979. Message(parser_e_no_type_not_allowed_here);
  980. end;
  981. function ttypenode.docompare(p: tnode): boolean;
  982. begin
  983. docompare :=
  984. inherited docompare(p);
  985. end;
  986. {*****************************************************************************
  987. TRTTINODE
  988. *****************************************************************************}
  989. constructor trttinode.create(def:tstoreddef;rt:trttitype);
  990. begin
  991. inherited create(rttin);
  992. rttidef:=def;
  993. rttitype:=rt;
  994. end;
  995. constructor trttinode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  996. begin
  997. inherited ppuload(t,ppufile);
  998. ppufile.getderef(rttidefderef);
  999. rttitype:=trttitype(ppufile.getbyte);
  1000. end;
  1001. procedure trttinode.ppuwrite(ppufile:tcompilerppufile);
  1002. begin
  1003. inherited ppuwrite(ppufile);
  1004. ppufile.putderef(rttidefderef);
  1005. ppufile.putbyte(byte(rttitype));
  1006. end;
  1007. procedure trttinode.buildderefimpl;
  1008. begin
  1009. inherited buildderefimpl;
  1010. rttidefderef.build(rttidef);
  1011. end;
  1012. procedure trttinode.derefimpl;
  1013. begin
  1014. inherited derefimpl;
  1015. rttidef:=tstoreddef(rttidefderef.resolve);
  1016. end;
  1017. function trttinode._getcopy : tnode;
  1018. var
  1019. n : trttinode;
  1020. begin
  1021. n:=trttinode(inherited _getcopy);
  1022. n.rttidef:=rttidef;
  1023. n.rttitype:=rttitype;
  1024. result:=n;
  1025. end;
  1026. function trttinode.det_resulttype:tnode;
  1027. begin
  1028. { rtti information will be returned as a void pointer }
  1029. result:=nil;
  1030. resulttype:=voidpointertype;
  1031. end;
  1032. function trttinode.pass_1 : tnode;
  1033. begin
  1034. result:=nil;
  1035. expectloc:=LOC_CREFERENCE;
  1036. end;
  1037. function trttinode.docompare(p: tnode): boolean;
  1038. begin
  1039. docompare :=
  1040. inherited docompare(p) and
  1041. (rttidef = trttinode(p).rttidef) and
  1042. (rttitype = trttinode(p).rttitype);
  1043. end;
  1044. begin
  1045. cloadnode:=tloadnode;
  1046. cassignmentnode:=tassignmentnode;
  1047. carrayconstructorrangenode:=tarrayconstructorrangenode;
  1048. carrayconstructornode:=tarrayconstructornode;
  1049. ctypenode:=ttypenode;
  1050. crttinode:=trttinode;
  1051. end.