nld.pas 45 KB

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