nld.pas 60 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565
  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. tloadnodeflags = (
  29. loadnf_is_self,
  30. loadnf_load_self_pointer,
  31. loadnf_inherited,
  32. { the loadnode is generated internally and a varspez=vs_const should be ignore,
  33. this requires that the parameter is actually passed by value
  34. Be really carefull when using this flag! }
  35. loadnf_isinternal_ignoreconst,
  36. loadnf_only_uninitialized_hint
  37. );
  38. tloadnode = class(tunarynode)
  39. protected
  40. fprocdef : tprocdef;
  41. fprocdefderef : tderef;
  42. function handle_threadvar_access: tnode; virtual;
  43. public
  44. loadnodeflags : set of tloadnodeflags;
  45. symtableentry : tsym;
  46. symtableentryderef : tderef;
  47. symtable : TSymtable;
  48. constructor create(v : tsym;st : TSymtable);virtual;
  49. constructor create_procvar(v : tsym;d:tprocdef;st : TSymtable);virtual;
  50. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  51. procedure ppuwrite(ppufile:tcompilerppufile);override;
  52. procedure buildderefimpl;override;
  53. procedure derefimpl;override;
  54. procedure set_mp(p:tnode);
  55. function is_addr_param_load:boolean;virtual;
  56. function dogetcopy : tnode;override;
  57. function pass_1 : tnode;override;
  58. function pass_typecheck:tnode;override;
  59. procedure mark_write;override;
  60. function docompare(p: tnode): boolean; override;
  61. procedure printnodedata(var t:text);override;
  62. procedure setprocdef(p : tprocdef);
  63. property procdef: tprocdef read fprocdef write setprocdef;
  64. end;
  65. tloadnodeclass = class of tloadnode;
  66. { different assignment types }
  67. tassigntype = (at_normal,at_plus,at_minus,at_star,at_slash);
  68. tassignmentnode = class(tbinarynode)
  69. protected
  70. function direct_shortstring_assignment: boolean; virtual;
  71. public
  72. assigntype : tassigntype;
  73. constructor create(l,r : tnode);virtual;
  74. { no checks for validity of assignment }
  75. constructor create_internal(l,r : tnode);virtual;
  76. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  77. procedure ppuwrite(ppufile:tcompilerppufile);override;
  78. function dogetcopy : tnode;override;
  79. function pass_1 : tnode;override;
  80. function pass_typecheck:tnode;override;
  81. function simplify(forinline : boolean) : tnode;override;
  82. {$ifdef state_tracking}
  83. function track_state_pass(exec_known:boolean):boolean;override;
  84. {$endif state_tracking}
  85. function docompare(p: tnode): boolean; override;
  86. end;
  87. tassignmentnodeclass = class of tassignmentnode;
  88. tarrayconstructorrangenode = class(tbinarynode)
  89. constructor create(l,r : tnode);virtual;
  90. function pass_1 : tnode;override;
  91. function pass_typecheck:tnode;override;
  92. end;
  93. tarrayconstructorrangenodeclass = class of tarrayconstructorrangenode;
  94. tarrayconstructornode = class(tbinarynode)
  95. protected
  96. procedure wrapmanagedvarrec(var n: tnode);virtual;abstract;
  97. public
  98. constructor create(l,r : tnode);virtual;
  99. function dogetcopy : tnode;override;
  100. function pass_1 : tnode;override;
  101. function pass_typecheck:tnode;override;
  102. function docompare(p: tnode): boolean; override;
  103. procedure force_type(def:tdef);
  104. procedure insert_typeconvs;
  105. end;
  106. tarrayconstructornodeclass = class of tarrayconstructornode;
  107. ttypenode = class(tnode)
  108. allowed : boolean;
  109. helperallowed : boolean;
  110. typedef : tdef;
  111. typedefderef : tderef;
  112. typesym : tsym;
  113. typesymderef : tderef;
  114. constructor create(def:tdef);virtual;
  115. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  116. procedure ppuwrite(ppufile:tcompilerppufile);override;
  117. procedure buildderefimpl;override;
  118. procedure derefimpl;override;
  119. function pass_1 : tnode;override;
  120. function pass_typecheck:tnode;override;
  121. function dogetcopy : tnode;override;
  122. function docompare(p: tnode): boolean; override;
  123. end;
  124. ttypenodeclass = class of ttypenode;
  125. trttinode = class(tnode)
  126. l1,l2 : longint;
  127. rttitype : trttitype;
  128. rttidef : tstoreddef;
  129. rttidefderef : tderef;
  130. rttidatatype : Trttidatatype;
  131. constructor create(def:tstoreddef;rt:trttitype;dt:Trttidatatype);virtual;
  132. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  133. procedure ppuwrite(ppufile:tcompilerppufile);override;
  134. procedure buildderefimpl;override;
  135. procedure derefimpl;override;
  136. function dogetcopy : tnode;override;
  137. function pass_1 : tnode;override;
  138. function pass_typecheck:tnode;override;
  139. function docompare(p: tnode): boolean; override;
  140. end;
  141. trttinodeclass = class of trttinode;
  142. var
  143. cloadnode : tloadnodeclass = tloadnode;
  144. cassignmentnode : tassignmentnodeclass = tassignmentnode;
  145. carrayconstructorrangenode : tarrayconstructorrangenodeclass = tarrayconstructorrangenode;
  146. carrayconstructornode : tarrayconstructornodeclass = tarrayconstructornode;
  147. ctypenode : ttypenodeclass = ttypenode;
  148. crttinode : trttinodeclass = trttinode;
  149. { Current assignment node }
  150. aktassignmentnode : tassignmentnode;
  151. implementation
  152. uses
  153. verbose,globtype,globals,systems,constexp,
  154. symtable,
  155. defutil,defcmp,
  156. htypechk,pass_1,procinfo,paramgr,
  157. cpuinfo,
  158. ncon,ninl,ncnv,nmem,ncal,nadd,nutils,
  159. cgbase
  160. ;
  161. {*****************************************************************************
  162. TLOADNODE
  163. *****************************************************************************}
  164. function tloadnode.handle_threadvar_access: tnode;
  165. begin
  166. { nothing special by default }
  167. result:=nil;
  168. end;
  169. constructor tloadnode.create(v : tsym;st : TSymtable);
  170. begin
  171. inherited create(loadn,nil);
  172. if not assigned(v) then
  173. internalerror(200108121);
  174. symtableentry:=v;
  175. symtable:=st;
  176. fprocdef:=nil;
  177. end;
  178. constructor tloadnode.create_procvar(v : tsym;d:tprocdef;st : TSymtable);
  179. begin
  180. inherited create(loadn,nil);
  181. if not assigned(v) then
  182. internalerror(200108122);
  183. symtableentry:=v;
  184. symtable:=st;
  185. fprocdef:=d;
  186. end;
  187. constructor tloadnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  188. begin
  189. inherited ppuload(t,ppufile);
  190. ppufile.getderef(symtableentryderef);
  191. symtable:=nil;
  192. ppufile.getderef(fprocdefderef);
  193. ppufile.getsmallset(loadnodeflags);
  194. end;
  195. procedure tloadnode.ppuwrite(ppufile:tcompilerppufile);
  196. begin
  197. inherited ppuwrite(ppufile);
  198. ppufile.putderef(symtableentryderef);
  199. ppufile.putderef(fprocdefderef);
  200. ppufile.putsmallset(loadnodeflags);
  201. end;
  202. procedure tloadnode.buildderefimpl;
  203. begin
  204. inherited buildderefimpl;
  205. symtableentryderef.build(symtableentry);
  206. fprocdefderef.build(fprocdef);
  207. end;
  208. procedure tloadnode.derefimpl;
  209. begin
  210. inherited derefimpl;
  211. symtableentry:=tsym(symtableentryderef.resolve);
  212. symtable:=symtableentry.owner;
  213. fprocdef:=tprocdef(fprocdefderef.resolve);
  214. end;
  215. procedure tloadnode.set_mp(p:tnode);
  216. begin
  217. { typen nodes should not be set }
  218. if p.nodetype=typen then
  219. internalerror(200301042);
  220. left:=p;
  221. end;
  222. function tloadnode.dogetcopy : tnode;
  223. var
  224. n : tloadnode;
  225. begin
  226. n:=tloadnode(inherited dogetcopy);
  227. n.symtable:=symtable;
  228. n.symtableentry:=symtableentry;
  229. n.fprocdef:=fprocdef;
  230. n.loadnodeflags:=loadnodeflags;
  231. result:=n;
  232. end;
  233. function tloadnode.is_addr_param_load:boolean;
  234. begin
  235. result:=(symtable.symtabletype=parasymtable) and
  236. (symtableentry.typ=paravarsym) and
  237. not(vo_has_local_copy in tparavarsym(symtableentry).varoptions) and
  238. not(loadnf_load_self_pointer in loadnodeflags) and
  239. paramanager.push_addr_param(tparavarsym(symtableentry).varspez,tparavarsym(symtableentry).vardef,tprocdef(symtable.defowner).proccalloption);
  240. end;
  241. function tloadnode.pass_typecheck:tnode;
  242. begin
  243. result:=nil;
  244. case symtableentry.typ of
  245. absolutevarsym :
  246. resultdef:=tabsolutevarsym(symtableentry).vardef;
  247. constsym:
  248. begin
  249. if tconstsym(symtableentry).consttyp=constresourcestring then
  250. resultdef:=getansistringdef
  251. else
  252. internalerror(22799);
  253. end;
  254. staticvarsym :
  255. begin
  256. tabstractvarsym(symtableentry).IncRefCountBy(1);
  257. { static variables referenced in procedures or from finalization,
  258. variable needs to be in memory.
  259. It is too hard and the benefit is too small to detect whether a
  260. variable is only used in the finalization to add support for it (PFV) }
  261. if assigned(current_procinfo) and
  262. (symtable.symtabletype=staticsymtable) and
  263. (
  264. (symtable.symtablelevel<>current_procinfo.procdef.localst.symtablelevel) or
  265. (current_procinfo.procdef.proctypeoption=potype_unitfinalize)
  266. ) then
  267. make_not_regable(self,[ra_addr_taken]);
  268. resultdef:=tabstractvarsym(symtableentry).vardef;
  269. if vo_is_thread_var in tstaticvarsym(symtableentry).varoptions then
  270. result:=handle_threadvar_access;
  271. end;
  272. paravarsym,
  273. localvarsym :
  274. begin
  275. tabstractvarsym(symtableentry).IncRefCountBy(1);
  276. { Nested variable? The we need to load the framepointer of
  277. the parent procedure }
  278. if assigned(current_procinfo) and
  279. (symtable.symtabletype in [localsymtable,parasymtable]) and
  280. (symtable.symtablelevel<>current_procinfo.procdef.parast.symtablelevel) then
  281. begin
  282. if assigned(left) then
  283. internalerror(200309289);
  284. left:=cloadparentfpnode.create(tprocdef(symtable.defowner),lpf_forload);
  285. { we can't inline the referenced parent procedure }
  286. exclude(tprocdef(symtable.defowner).procoptions,po_inline);
  287. { reference in nested procedures, variable needs to be in memory }
  288. { and behaves as if its address escapes its parent block }
  289. make_not_regable(self,[ra_addr_taken]);
  290. end;
  291. resultdef:=tabstractvarsym(symtableentry).vardef;
  292. { self for objects is passed as var-parameter on the caller
  293. side, but on the callee-side we use it as a pointer ->
  294. adjust }
  295. if (vo_is_self in tabstractvarsym(symtableentry).varoptions) then
  296. begin
  297. if (is_object(resultdef) or is_record(resultdef)) and
  298. (loadnf_load_self_pointer in loadnodeflags) then
  299. resultdef:=cpointerdef.getreusable(resultdef)
  300. else if (resultdef=objc_idtype) and
  301. (po_classmethod in tprocdef(symtableentry.owner.defowner).procoptions) then
  302. resultdef:=cclassrefdef.create(tprocdef(symtableentry.owner.defowner).struct)
  303. end
  304. end;
  305. procsym :
  306. begin
  307. { Return the first procdef. In case of overloaded
  308. procdefs the matching procdef will be choosen
  309. when the expected procvardef is known, see get_information
  310. in htypechk.pas (PFV) }
  311. if not assigned(fprocdef) then
  312. fprocdef:=tprocdef(tprocsym(symtableentry).ProcdefList[0])
  313. else if po_kylixlocal in fprocdef.procoptions then
  314. CGMessage(type_e_cant_take_address_of_local_subroutine);
  315. { the result is a fprocdef, addrn and proc_to_procvar
  316. typeconvn need this as resultdef so they know
  317. that the address needs to be returned }
  318. resultdef:=fprocdef;
  319. { process methodpointer/framepointer }
  320. if assigned(left) then
  321. begin
  322. typecheckpass(left);
  323. if (po_classmethod in fprocdef.procoptions) and
  324. is_class(left.resultdef) and
  325. (left.nodetype<>niln) then
  326. begin
  327. left:=cloadvmtaddrnode.create(left);
  328. typecheckpass(left);
  329. end
  330. end;
  331. end;
  332. labelsym:
  333. begin
  334. tlabelsym(symtableentry).used:=true;
  335. resultdef:=voidtype;
  336. end;
  337. else
  338. internalerror(200104141);
  339. end;
  340. end;
  341. procedure Tloadnode.mark_write;
  342. begin
  343. include(flags,nf_write);
  344. end;
  345. function tloadnode.pass_1 : tnode;
  346. begin
  347. result:=nil;
  348. expectloc:=LOC_REFERENCE;
  349. if (cs_create_pic in current_settings.moduleswitches) and
  350. not(symtableentry.typ in [paravarsym,localvarsym]) then
  351. include(current_procinfo.flags,pi_needs_got);
  352. case symtableentry.typ of
  353. absolutevarsym :
  354. ;
  355. constsym:
  356. begin
  357. if tconstsym(symtableentry).consttyp=constresourcestring then
  358. expectloc:=LOC_CREFERENCE;
  359. end;
  360. staticvarsym,
  361. localvarsym,
  362. paravarsym :
  363. begin
  364. if assigned(left) then
  365. firstpass(left);
  366. if not is_addr_param_load and
  367. tabstractvarsym(symtableentry).is_regvar(is_addr_param_load) then
  368. expectloc:=tvarregable2tcgloc[tabstractvarsym(symtableentry).varregable]
  369. else
  370. if (tabstractvarsym(symtableentry).varspez=vs_const) then
  371. expectloc:=LOC_CREFERENCE;
  372. if (target_info.system=system_powerpc_darwin) and
  373. ([vo_is_dll_var,vo_is_external] * tabstractvarsym(symtableentry).varoptions <> []) then
  374. include(current_procinfo.flags,pi_needs_got);
  375. { call to get address of threadvar }
  376. if (vo_is_thread_var in tabstractvarsym(symtableentry).varoptions) then
  377. include(current_procinfo.flags,pi_do_call);
  378. end;
  379. procsym :
  380. begin
  381. { initialise left for nested procs if necessary }
  382. if (m_nested_procvars in current_settings.modeswitches) then
  383. setprocdef(fprocdef);
  384. { method pointer or nested proc ? }
  385. if assigned(left) then
  386. begin
  387. expectloc:=LOC_CREGISTER;
  388. firstpass(left);
  389. end;
  390. end;
  391. labelsym :
  392. begin
  393. if not assigned(tlabelsym(symtableentry).asmblocklabel) and
  394. not assigned(tlabelsym(symtableentry).code) then
  395. Message(parser_e_label_outside_proc);
  396. end
  397. else
  398. internalerror(200104143);
  399. end;
  400. end;
  401. function tloadnode.docompare(p: tnode): boolean;
  402. begin
  403. docompare :=
  404. inherited docompare(p) and
  405. (symtableentry = tloadnode(p).symtableentry) and
  406. (fprocdef = tloadnode(p).fprocdef) and
  407. (symtable = tloadnode(p).symtable);
  408. end;
  409. procedure tloadnode.printnodedata(var t:text);
  410. begin
  411. inherited printnodedata(t);
  412. write(t,printnodeindention,'symbol = ',symtableentry.name);
  413. if symtableentry.typ=procsym then
  414. write(t,printnodeindention,'procdef = ',fprocdef.mangledname);
  415. writeln(t,'');
  416. end;
  417. procedure tloadnode.setprocdef(p : tprocdef);
  418. begin
  419. fprocdef:=p;
  420. resultdef:=p;
  421. { nested procedure? }
  422. if assigned(p) and
  423. is_nested_pd(p) then
  424. begin
  425. if not(m_nested_procvars in current_settings.modeswitches) then
  426. CGMessage(type_e_cant_take_address_of_local_subroutine)
  427. else
  428. begin
  429. { parent frame pointer pointer as "self" }
  430. left.free;
  431. left:=cloadparentfpnode.create(tprocdef(p.owner.defowner),lpf_forpara);
  432. end;
  433. end
  434. { we should never go from nested to non-nested }
  435. else if assigned(left) and
  436. (left.nodetype=loadparentfpn) then
  437. internalerror(2010072201);
  438. end;
  439. {*****************************************************************************
  440. TASSIGNMENTNODE
  441. *****************************************************************************}
  442. function tassignmentnode.direct_shortstring_assignment: boolean;
  443. begin
  444. result:=
  445. is_char(right.resultdef) or
  446. (right.resultdef.typ=stringdef);
  447. end;
  448. constructor tassignmentnode.create(l,r : tnode);
  449. begin
  450. inherited create(assignn,l,r);
  451. l.mark_write;
  452. assigntype:=at_normal;
  453. if r.nodetype = typeconvn then
  454. ttypeconvnode(r).warn_pointer_to_signed:=false;
  455. end;
  456. constructor tassignmentnode.create_internal(l, r: tnode);
  457. begin
  458. create(l,r);
  459. include(flags,nf_internal);
  460. end;
  461. constructor tassignmentnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  462. begin
  463. inherited ppuload(t,ppufile);
  464. assigntype:=tassigntype(ppufile.getbyte);
  465. end;
  466. procedure tassignmentnode.ppuwrite(ppufile:tcompilerppufile);
  467. begin
  468. inherited ppuwrite(ppufile);
  469. ppufile.putbyte(byte(assigntype));
  470. end;
  471. function tassignmentnode.dogetcopy : tnode;
  472. var
  473. n : tassignmentnode;
  474. begin
  475. n:=tassignmentnode(inherited dogetcopy);
  476. n.assigntype:=assigntype;
  477. result:=n;
  478. end;
  479. function tassignmentnode.simplify(forinline : boolean) : tnode;
  480. var
  481. newinlinenodetype : byte;
  482. begin
  483. result:=nil;
  484. { assignment nodes can perform several floating point }
  485. { type conversions directly, so no typeconversions }
  486. { are inserted in those cases. When inlining, a }
  487. { variable may be replaced by a constant which can be }
  488. { converted at compile time, so check for this case }
  489. if is_real(left.resultdef) and
  490. is_real(right.resultdef) and
  491. is_constrealnode(right) and
  492. not equal_defs(right.resultdef,left.resultdef) then
  493. inserttypeconv(right,left.resultdef);
  494. if cs_opt_level2 in current_settings.optimizerswitches then
  495. begin
  496. { replace i:=succ/pred(i) by inc/dec(i)? }
  497. if (right.nodetype=inlinen) and
  498. ((tinlinenode(right).inlinenumber=in_succ_x) or (tinlinenode(right).inlinenumber=in_pred_x)) and
  499. (tinlinenode(right).left.isequal(left)) and
  500. ((localswitches*[cs_check_overflow,cs_check_range])=[]) and
  501. ((right.localswitches*[cs_check_overflow,cs_check_range])=[]) and
  502. valid_for_var(tinlinenode(right).left,false) and
  503. not(might_have_sideeffects(tinlinenode(right).left)) then
  504. begin
  505. if tinlinenode(right).inlinenumber=in_succ_x then
  506. newinlinenodetype:=in_inc_x
  507. else
  508. newinlinenodetype:=in_dec_x;
  509. result:=cinlinenode.createintern(
  510. newinlinenodetype,false,ccallparanode.create(
  511. tinlinenode(right).left,nil));
  512. tinlinenode(right).left:=nil;
  513. exit;
  514. end;
  515. if cs_opt_level3 in current_settings.optimizerswitches then
  516. begin
  517. { replace i:=i+k by inc(i,k)
  518. i:=i-k by dec(i,k)
  519. i:=i and/or/xor k by in_[and/or/xor]_assign_x_y(i,k)
  520. this handles the case, where there are no implicit type conversions }
  521. if (right.nodetype in [addn,subn,andn,orn,xorn]) and
  522. (taddnode(right).left.isequal(left)) and
  523. is_integer(taddnode(right).left.resultdef) and
  524. is_integer(taddnode(right).right.resultdef) and
  525. ((localswitches*[cs_check_overflow,cs_check_range])=[]) and
  526. ((right.localswitches*[cs_check_overflow,cs_check_range])=[]) and
  527. valid_for_var(taddnode(right).left,false) and
  528. not(might_have_sideeffects(taddnode(right).left)) then
  529. begin
  530. case right.nodetype of
  531. addn:
  532. newinlinenodetype:=in_inc_x;
  533. subn:
  534. newinlinenodetype:=in_dec_x;
  535. andn:
  536. newinlinenodetype:=in_and_assign_x_y;
  537. orn:
  538. newinlinenodetype:=in_or_assign_x_y;
  539. xorn:
  540. newinlinenodetype:=in_xor_assign_x_y;
  541. else
  542. internalerror(2017032901);
  543. end;
  544. if right.nodetype in [addn,subn] then
  545. result:=cinlinenode.createintern(
  546. newinlinenodetype,false,ccallparanode.create(
  547. taddnode(right).left,ccallparanode.create(taddnode(right).right,nil)))
  548. else
  549. result:=cinlinenode.createintern(
  550. newinlinenodetype,false,ccallparanode.create(
  551. taddnode(right).right,ccallparanode.create(taddnode(right).left,nil)));
  552. taddnode(right).left:=nil;
  553. taddnode(right).right:=nil;
  554. exit;
  555. end;
  556. { replace i:=i+k by inc(i,k)
  557. i:=i-k by dec(i,k)
  558. i:=i and/or/xor k by in_[and/or/xor]_assign_x_y(i,k)
  559. this handles the case with two conversions (outer and inner):
  560. outer typeconv: right
  561. add/sub/and/or/xor: ttypeconvnode(right).left
  562. inner typeconv: taddnode(ttypeconvnode(right).left).left
  563. right side 'i': ttypeconvnode(taddnode(ttypeconvnode(right).left).left).left
  564. right side 'k': taddnode(ttypeconvnode(right).left).right }
  565. if (right.nodetype=typeconvn) and
  566. (ttypeconvnode(right).convtype=tc_int_2_int) and
  567. (ttypeconvnode(right).left.nodetype in [addn,subn,andn,orn,xorn]) and
  568. is_integer(ttypeconvnode(right).left.resultdef) and
  569. (right.resultdef.size<=ttypeconvnode(right).left.resultdef.size) and
  570. (taddnode(ttypeconvnode(right).left).left.nodetype=typeconvn) and
  571. (ttypeconvnode(taddnode(ttypeconvnode(right).left).left).convtype=tc_int_2_int) and
  572. are_equal_ints(right.resultdef,ttypeconvnode(taddnode(ttypeconvnode(right).left).left).left.resultdef) and
  573. ttypeconvnode(taddnode(ttypeconvnode(right).left).left).left.isequal(left) and
  574. is_integer(taddnode(ttypeconvnode(right).left).left.resultdef) and
  575. is_integer(taddnode(ttypeconvnode(right).left).right.resultdef) and
  576. is_integer(ttypeconvnode(taddnode(ttypeconvnode(right).left).left).left.resultdef) and
  577. ((localswitches*[cs_check_overflow,cs_check_range])=[]) and
  578. ((right.localswitches*[cs_check_overflow,cs_check_range])=[]) and
  579. valid_for_var(ttypeconvnode(taddnode(ttypeconvnode(right).left).left).left,false) and
  580. not(might_have_sideeffects(ttypeconvnode(taddnode(ttypeconvnode(right).left).left).left)) then
  581. begin
  582. case ttypeconvnode(right).left.nodetype of
  583. addn:
  584. newinlinenodetype:=in_inc_x;
  585. subn:
  586. newinlinenodetype:=in_dec_x;
  587. andn:
  588. newinlinenodetype:=in_and_assign_x_y;
  589. orn:
  590. newinlinenodetype:=in_or_assign_x_y;
  591. xorn:
  592. newinlinenodetype:=in_xor_assign_x_y;
  593. else
  594. internalerror(2017032901);
  595. end;
  596. inserttypeconv_internal(taddnode(ttypeconvnode(right).left).right,left.resultdef);
  597. if ttypeconvnode(right).left.nodetype in [addn,subn] then
  598. result:=cinlinenode.createintern(
  599. newinlinenodetype,false,ccallparanode.create(
  600. ttypeconvnode(taddnode(ttypeconvnode(right).left).left).left,ccallparanode.create(taddnode(ttypeconvnode(right).left).right,nil)))
  601. else
  602. result:=cinlinenode.createintern(
  603. newinlinenodetype,false,ccallparanode.create(
  604. taddnode(ttypeconvnode(right).left).right,ccallparanode.create(ttypeconvnode(taddnode(ttypeconvnode(right).left).left).left,nil)));
  605. ttypeconvnode(taddnode(ttypeconvnode(right).left).left).left:=nil;
  606. taddnode(ttypeconvnode(right).left).right:=nil;
  607. exit;
  608. end;
  609. { replace i:=k+i by inc(i,k)
  610. i:=k and/or/xor i by in_[and/or/xor]_assign_x_y(i,k)
  611. todo: for some integer types, there are extra implicit
  612. typecasts inserted by the compiler; this code should be
  613. updated to handle them as well }
  614. if (right.nodetype in [addn,andn,orn,xorn]) and
  615. (taddnode(right).right.isequal(left)) and
  616. is_integer(taddnode(right).left.resultdef) and
  617. is_integer(taddnode(right).right.resultdef) and
  618. ((localswitches*[cs_check_overflow,cs_check_range])=[]) and
  619. ((right.localswitches*[cs_check_overflow,cs_check_range])=[]) and
  620. valid_for_var(taddnode(right).right,false) and
  621. not(might_have_sideeffects(taddnode(right).right)) then
  622. begin
  623. case right.nodetype of
  624. addn:
  625. newinlinenodetype:=in_inc_x;
  626. andn:
  627. newinlinenodetype:=in_and_assign_x_y;
  628. orn:
  629. newinlinenodetype:=in_or_assign_x_y;
  630. xorn:
  631. newinlinenodetype:=in_xor_assign_x_y;
  632. else
  633. internalerror(2017032902);
  634. end;
  635. if right.nodetype=addn then
  636. result:=cinlinenode.createintern(
  637. newinlinenodetype,false,ccallparanode.create(
  638. taddnode(right).right,ccallparanode.create(taddnode(right).left,nil)))
  639. else
  640. result:=cinlinenode.createintern(
  641. newinlinenodetype,false,ccallparanode.create(
  642. taddnode(right).left,ccallparanode.create(taddnode(right).right,nil)));
  643. taddnode(right).right:=nil;
  644. taddnode(right).left:=nil;
  645. exit;
  646. end;
  647. { replace i:=not i by in_not_assign_x(i)
  648. i:=-i by in_neg_assign_x(i)
  649. this handles the case, where there are no implicit type conversions }
  650. if (right.nodetype in [notn,unaryminusn]) and
  651. (tunarynode(right).left.isequal(left)) and
  652. is_integer(tunarynode(right).left.resultdef) and
  653. ((localswitches*[cs_check_overflow,cs_check_range])=[]) and
  654. ((right.localswitches*[cs_check_overflow,cs_check_range])=[]) and
  655. valid_for_var(tunarynode(right).left,false) and
  656. not(might_have_sideeffects(tunarynode(right).left)) then
  657. begin
  658. if right.nodetype=notn then
  659. newinlinenodetype:=in_not_assign_x
  660. else
  661. newinlinenodetype:=in_neg_assign_x;
  662. result:=cinlinenode.createintern(
  663. newinlinenodetype,false,tunarynode(right).left);
  664. tunarynode(right).left:=nil;
  665. exit;
  666. end;
  667. { replace i:=not i by in_not_assign_x(i)
  668. i:=-i by in_neg_assign_x(i)
  669. this handles the case with type conversions:
  670. outer typeconv: right
  671. neg/not: ttypeconvnode(right).left
  672. inner typeconv: tunarynode(ttypeconvnode(right).left).left
  673. right side 'i': ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left }
  674. if (right.nodetype=typeconvn) and
  675. (ttypeconvnode(right).convtype=tc_int_2_int) and
  676. (ttypeconvnode(right).left.nodetype in [notn,unaryminusn]) and
  677. is_integer(ttypeconvnode(right).left.resultdef) and
  678. (right.resultdef.size<=ttypeconvnode(right).left.resultdef.size) and
  679. (tunarynode(ttypeconvnode(right).left).left.nodetype=typeconvn) and
  680. (ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).convtype=tc_int_2_int) and
  681. are_equal_ints(right.resultdef,ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left.resultdef) and
  682. ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left.isequal(left) and
  683. is_integer(ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left.resultdef) and
  684. ((localswitches*[cs_check_overflow,cs_check_range])=[]) and
  685. ((right.localswitches*[cs_check_overflow,cs_check_range])=[]) and
  686. valid_for_var(ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left,false) and
  687. not(might_have_sideeffects(ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left)) then
  688. begin
  689. if ttypeconvnode(right).left.nodetype=notn then
  690. newinlinenodetype:=in_not_assign_x
  691. else
  692. newinlinenodetype:=in_neg_assign_x;
  693. result:=cinlinenode.createintern(
  694. newinlinenodetype,false,ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left);
  695. ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left:=nil;
  696. exit;
  697. end;
  698. end;
  699. end;
  700. end;
  701. function tassignmentnode.pass_typecheck:tnode;
  702. var
  703. hp : tnode;
  704. useshelper : boolean;
  705. oldassignmentnode : tassignmentnode;
  706. begin
  707. result:=nil;
  708. resultdef:=voidtype;
  709. { must be made unique }
  710. set_unique(left);
  711. typecheckpass(left);
  712. { PI. This is needed to return correct resultdef of add nodes for ansistrings
  713. rawbytestring return needs to be replaced by left.resultdef }
  714. oldassignmentnode:=aktassignmentnode;
  715. aktassignmentnode:=self;
  716. typecheckpass(right);
  717. aktassignmentnode:=oldassignmentnode;
  718. set_varstate(right,vs_read,[vsf_must_be_valid]);
  719. set_varstate(left,vs_written,[]);
  720. if codegenerror then
  721. exit;
  722. { tp procvar support, when we don't expect a procvar
  723. then we need to call the procvar }
  724. if (left.resultdef.typ<>procvardef) then
  725. maybe_call_procvar(right,true);
  726. { assignments to formaldefs and open arrays aren't allowed }
  727. if is_open_array(left.resultdef) then
  728. CGMessage(type_e_assignment_not_allowed)
  729. else if (left.resultdef.typ=formaldef) then
  730. if not(target_info.system in systems_managed_vm) then
  731. CGMessage(type_e_assignment_not_allowed)
  732. else
  733. begin
  734. { on managed platforms, assigning to formaldefs is allowed (but
  735. typecasting them on the left hand side isn't), but primitive
  736. values need to be boxed first }
  737. if (right.resultdef.typ in [orddef,floatdef]) then
  738. begin
  739. right:=cinlinenode.create(in_box_x,false,ccallparanode.create(right,nil));
  740. typecheckpass(right);
  741. end;
  742. end;
  743. { test if node can be assigned, properties are allowed }
  744. if not(nf_internal in flags) then
  745. if not valid_for_assignment(left,true) then
  746. { errors can in situations that cause the compiler to run out of
  747. memory, such as assigning to an implicit pointer-to-array
  748. converted node (that array is 2^31 or 2^63 bytes large) }
  749. exit;
  750. { assigning nil to a dynamic array clears the array }
  751. if is_dynamic_array(left.resultdef) and
  752. (right.nodetype=niln) then
  753. begin
  754. { remove property flag to avoid errors, see comments for }
  755. { tf_winlikewidestring assignments below }
  756. exclude(left.flags,nf_isproperty);
  757. { generate a setlength node so it can be intercepted by
  758. target-specific code }
  759. result:=cinlinenode.create(in_setlength_x,false,
  760. ccallparanode.create(genintconstnode(0),
  761. ccallparanode.create(left,nil)));
  762. left:=nil;
  763. exit;
  764. end;
  765. { shortstring helpers can do the conversion directly,
  766. so treat them separatly }
  767. if (is_shortstring(left.resultdef)) then
  768. begin
  769. { insert typeconv, except for chars that are handled in
  770. secondpass and except for ansi/wide string that can
  771. be converted immediatly }
  772. if not direct_shortstring_assignment then
  773. inserttypeconv(right,left.resultdef);
  774. if right.resultdef.typ=stringdef then
  775. begin
  776. useshelper:=true;
  777. { convert constant strings to shortstrings. But
  778. skip empty constant strings, that will be handled
  779. in secondpass }
  780. if (right.nodetype=stringconstn) then
  781. begin
  782. { verify if range fits within shortstring }
  783. { just emit a warning, delphi gives an }
  784. { error, only if the type definition of }
  785. { of the string is less < 255 characters }
  786. if not is_open_string(left.resultdef) and
  787. (tstringconstnode(right).len > tstringdef(left.resultdef).len) then
  788. cgmessage(type_w_string_too_long);
  789. inserttypeconv(right,left.resultdef);
  790. if (right.nodetype=stringconstn) and
  791. (tstringconstnode(right).len=0) then
  792. useshelper:=false;
  793. end
  794. else if (tstringdef(right.resultdef).stringtype in [st_unicodestring,st_widestring]) then
  795. Message2(type_w_implicit_string_cast_loss,right.resultdef.typename,left.resultdef.typename);
  796. { rest is done in pass 1 (JM) }
  797. if useshelper then
  798. exit;
  799. end
  800. end
  801. { floating point assignments can also perform the conversion directly }
  802. else if is_real(left.resultdef) and is_real(right.resultdef) and
  803. not is_constrealnode(right)
  804. {$ifdef cpufpemu}
  805. { the emulator can't do this obviously }
  806. and not(current_settings.fputype in [fpu_libgcc,fpu_soft])
  807. {$endif cpufpemu}
  808. {$ifdef x86}
  809. { the assignment node code can't convert a double in an }
  810. { sse register to an extended value in memory more }
  811. { efficiently than a type conversion node, so don't }
  812. { bother implementing support for that }
  813. and (use_vectorfpu(left.resultdef) or not(use_vectorfpu(right.resultdef)))
  814. {$endif}
  815. {$ifdef arm}
  816. { the assignment node code can't convert a single in
  817. an interger register to a double in an mmregister or
  818. vice versa }
  819. and (use_vectorfpu(left.resultdef) and
  820. use_vectorfpu(right.resultdef) and
  821. (tfloatdef(left.resultdef).floattype=tfloatdef(right.resultdef).floattype))
  822. {$endif}
  823. then
  824. begin
  825. if not(nf_internal in flags) then
  826. check_ranges(fileinfo,right,left.resultdef);
  827. end
  828. else
  829. begin
  830. { check if the assignment may cause a range check error }
  831. if not(nf_internal in flags) then
  832. check_ranges(fileinfo,right,left.resultdef);
  833. { beginners might be confused about an error message like
  834. Incompatible types: got "untyped" expected "LongInt"
  835. when trying to assign the result of a procedure, so give
  836. a better error message, see also #19122 }
  837. if (left.resultdef.typ<>procvardef) and
  838. (right.nodetype=calln) and is_void(right.resultdef) then
  839. CGMessage(type_e_procedures_return_no_value)
  840. else if nf_internal in flags then
  841. inserttypeconv_internal(right,left.resultdef)
  842. else
  843. inserttypeconv(right,left.resultdef);
  844. end;
  845. { call helpers for interface }
  846. if is_interfacecom_or_dispinterface(left.resultdef) then
  847. begin
  848. { Normal interface assignments are handled by the generic refcount incr/decr }
  849. if not def_is_related(right.resultdef,left.resultdef) then
  850. begin
  851. { remove property flag to avoid errors, see comments for }
  852. { tf_winlikewidestring assignments below }
  853. exclude(left.flags,nf_isproperty);
  854. hp:=
  855. ccallparanode.create(
  856. cguidconstnode.create(tobjectdef(left.resultdef).iidguid^),
  857. ccallparanode.create(
  858. ctypeconvnode.create_internal(right,voidpointertype),
  859. ccallparanode.create(
  860. ctypeconvnode.create_internal(left,voidpointertype),
  861. nil)));
  862. result:=ccallnode.createintern('fpc_intf_assign_by_iid',hp);
  863. left:=nil;
  864. right:=nil;
  865. exit;
  866. end;
  867. end;
  868. { check if local proc/func is assigned to procvar }
  869. if right.resultdef.typ=procvardef then
  870. test_local_to_procvar(tprocvardef(right.resultdef),left.resultdef);
  871. end;
  872. function tassignmentnode.pass_1 : tnode;
  873. var
  874. hp: tnode;
  875. oldassignmentnode : tassignmentnode;
  876. hdef: tdef;
  877. hs: string;
  878. needrtti: boolean;
  879. begin
  880. result:=nil;
  881. expectloc:=LOC_VOID;
  882. firstpass(left);
  883. { Optimize the reuse of the destination of the assingment in left.
  884. Allow the use of the left inside the tree generated on the right.
  885. This is especially useful for string routines where the destination
  886. is pushed as a parameter. Using the final destination of left directly
  887. save a temp allocation and copy of data (PFV) }
  888. oldassignmentnode:=aktassignmentnode;
  889. aktassignmentnode:=self;
  890. firstpass(right);
  891. aktassignmentnode:=oldassignmentnode;
  892. if nf_assign_done_in_right in flags then
  893. begin
  894. result:=right;
  895. right:=nil;
  896. exit;
  897. end;
  898. if codegenerror then
  899. exit;
  900. { assignment to refcounted variable -> inc/decref }
  901. if is_managed_type(left.resultdef) then
  902. include(current_procinfo.flags,pi_do_call);
  903. needrtti:=false;
  904. if (is_shortstring(left.resultdef)) then
  905. begin
  906. if right.resultdef.typ=stringdef then
  907. begin
  908. if (right.nodetype<>stringconstn) or
  909. (tstringconstnode(right).len<>0) then
  910. begin
  911. { remove property flag to avoid errors, see comments for }
  912. { tf_winlikewidestring assignments below }
  913. exclude(left.flags, nf_isproperty);
  914. hp:=ccallparanode.create
  915. (right,
  916. ccallparanode.create(left,nil));
  917. result:=ccallnode.createintern('fpc_'+tstringdef(right.resultdef).stringtypname+'_to_shortstr',hp);
  918. firstpass(result);
  919. left:=nil;
  920. right:=nil;
  921. end;
  922. end;
  923. exit;
  924. end
  925. { call helpers for composite types containing automated types }
  926. else if is_managed_type(left.resultdef) and
  927. (left.resultdef.typ in [arraydef,objectdef,recorddef]) and
  928. not is_interfacecom_or_dispinterface(left.resultdef) and
  929. not is_dynamic_array(left.resultdef) and
  930. not is_const(left) and
  931. not(target_info.system in systems_garbage_collected_managed_types) then
  932. begin
  933. hp:=ccallparanode.create(caddrnode.create_internal(
  934. crttinode.create(tstoreddef(left.resultdef),initrtti,rdt_normal)),
  935. ccallparanode.create(ctypeconvnode.create_internal(
  936. caddrnode.create_internal(left),voidpointertype),
  937. ccallparanode.create(ctypeconvnode.create_internal(
  938. caddrnode.create_internal(right),voidpointertype),
  939. nil)));
  940. result:=ccallnode.createintern('fpc_copy_proc',hp);
  941. firstpass(result);
  942. left:=nil;
  943. right:=nil;
  944. exit;
  945. end
  946. { call helpers for variant, they can contain non ref. counted types like
  947. vararrays which must be really copied }
  948. else if (left.resultdef.typ=variantdef) and
  949. not(is_const(left)) and
  950. not(target_info.system in systems_garbage_collected_managed_types) then
  951. begin
  952. { remove property flag to avoid errors, see comments for }
  953. { tf_winlikewidestring assignments below }
  954. exclude(left.flags,nf_isproperty);
  955. hdef:=search_system_type('TVARDATA').typedef;
  956. hp:=ccallparanode.create(ctypeconvnode.create_internal(
  957. right,hdef),
  958. ccallparanode.create(ctypeconvnode.create_internal(
  959. left,hdef),
  960. nil));
  961. result:=ccallnode.createintern('fpc_variant_copy',hp);
  962. firstpass(result);
  963. left:=nil;
  964. right:=nil;
  965. exit;
  966. end
  967. else if not(target_info.system in systems_garbage_collected_managed_types) and
  968. not(is_const(left)) then
  969. begin
  970. { call helpers for pointer-sized managed types }
  971. if is_widestring(left.resultdef) then
  972. hs:='fpc_widestr_assign'
  973. else if is_ansistring(left.resultdef) then
  974. hs:='fpc_ansistr_assign'
  975. else if is_unicodestring(left.resultdef) then
  976. hs:='fpc_unicodestr_assign'
  977. else if is_interfacecom_or_dispinterface(left.resultdef) then
  978. hs:='fpc_intf_assign'
  979. else if is_dynamic_array(left.resultdef) then
  980. begin
  981. hs:='fpc_dynarray_assign';
  982. needrtti:=true;
  983. end
  984. else
  985. exit;
  986. end
  987. else
  988. exit;
  989. { The first argument of these procedures is a var parameter. Properties cannot }
  990. { be passed to var or out parameters, because in that case setters/getters are not }
  991. { used. Further, if we would allow it in case there are no getters or setters, you }
  992. { would need source changes in case these are introduced later on, thus defeating }
  993. { part of the transparency advantages of properties. In this particular case, }
  994. { however: }
  995. { a) if there is a setter, this code will not be used since then the assignment }
  996. { will be converted to a procedure call }
  997. { b) the getter is irrelevant, because fpc_widestr_assign must always decrease }
  998. { the refcount of the field to which we are writing }
  999. { c) source code changes are not required if a setter is added/removed, because }
  1000. { this transformation is handled at compile time }
  1001. { -> we can remove the nf_isproperty flag (if any) from left, so that in case it }
  1002. { is a property which refers to a field without a setter call, we will not get }
  1003. { an error about trying to pass a property as a var parameter }
  1004. exclude(left.flags,nf_isproperty);
  1005. hp:=ccallparanode.create(ctypeconvnode.create_internal(right,voidpointertype),
  1006. ccallparanode.create(ctypeconvnode.create_internal(left,voidpointertype),
  1007. nil));
  1008. if needrtti then
  1009. hp:=ccallparanode.create(
  1010. caddrnode.create_internal(
  1011. crttinode.create(tstoreddef(left.resultdef),initrtti,rdt_normal)),
  1012. hp);
  1013. result:=ccallnode.createintern(hs,hp);
  1014. firstpass(result);
  1015. left:=nil;
  1016. right:=nil;
  1017. end;
  1018. function tassignmentnode.docompare(p: tnode): boolean;
  1019. begin
  1020. docompare :=
  1021. inherited docompare(p) and
  1022. (assigntype = tassignmentnode(p).assigntype);
  1023. end;
  1024. {$ifdef state_tracking}
  1025. function Tassignmentnode.track_state_pass(exec_known:boolean):boolean;
  1026. var se:Tstate_entry;
  1027. begin
  1028. track_state_pass:=false;
  1029. if exec_known then
  1030. begin
  1031. track_state_pass:=right.track_state_pass(exec_known);
  1032. {Force a new resultdef pass.}
  1033. right.resultdef:=nil;
  1034. do_typecheckpass(right);
  1035. typecheckpass(right);
  1036. aktstate.store_fact(left.getcopy,right.getcopy);
  1037. end
  1038. else
  1039. aktstate.delete_fact(left);
  1040. end;
  1041. {$endif}
  1042. {*****************************************************************************
  1043. TARRAYCONSTRUCTORRANGENODE
  1044. *****************************************************************************}
  1045. constructor tarrayconstructorrangenode.create(l,r : tnode);
  1046. begin
  1047. inherited create(arrayconstructorrangen,l,r);
  1048. end;
  1049. function tarrayconstructorrangenode.pass_typecheck:tnode;
  1050. begin
  1051. result:=nil;
  1052. typecheckpass(left);
  1053. typecheckpass(right);
  1054. set_varstate(left,vs_read,[vsf_must_be_valid]);
  1055. set_varstate(right,vs_read,[vsf_must_be_valid]);
  1056. if codegenerror then
  1057. exit;
  1058. resultdef:=left.resultdef;
  1059. end;
  1060. function tarrayconstructorrangenode.pass_1 : tnode;
  1061. begin
  1062. result:=nil;
  1063. CGMessage(parser_e_illegal_expression);
  1064. end;
  1065. {****************************************************************************
  1066. TARRAYCONSTRUCTORNODE
  1067. *****************************************************************************}
  1068. constructor tarrayconstructornode.create(l,r : tnode);
  1069. begin
  1070. inherited create(arrayconstructorn,l,r);
  1071. end;
  1072. function tarrayconstructornode.dogetcopy : tnode;
  1073. var
  1074. n : tarrayconstructornode;
  1075. begin
  1076. n:=tarrayconstructornode(inherited dogetcopy);
  1077. result:=n;
  1078. end;
  1079. function tarrayconstructornode.pass_typecheck:tnode;
  1080. var
  1081. hdef : tdef;
  1082. hp : tarrayconstructornode;
  1083. len : longint;
  1084. varia : boolean;
  1085. eq : tequaltype;
  1086. hnodetype : tnodetype;
  1087. begin
  1088. result:=nil;
  1089. { are we allowing array constructor? Then convert it to a set.
  1090. Do this only if we didn't convert the arrayconstructor yet. This
  1091. is needed for the cases where the resultdef is forced for a second
  1092. run }
  1093. if not(allow_array_constructor) then
  1094. begin
  1095. hp:=tarrayconstructornode(getcopy);
  1096. arrayconstructor_to_set(tnode(hp));
  1097. result:=hp;
  1098. exit;
  1099. end;
  1100. { only pass left tree, right tree contains next construct if any }
  1101. hdef:=nil;
  1102. hnodetype:=errorn;
  1103. len:=0;
  1104. varia:=false;
  1105. if assigned(left) then
  1106. begin
  1107. hp:=self;
  1108. while assigned(hp) do
  1109. begin
  1110. typecheckpass(hp.left);
  1111. set_varstate(hp.left,vs_read,[vsf_must_be_valid]);
  1112. if (hdef=nil) then
  1113. begin
  1114. hdef:=hp.left.resultdef;
  1115. hnodetype:=hp.left.nodetype;
  1116. end
  1117. else
  1118. begin
  1119. { If we got a niln we don't know the type yet and need to take the
  1120. type of the next array element.
  1121. This is to handle things like [nil,tclass,tclass], see also tw8371 (PFV) }
  1122. if hnodetype=niln then
  1123. begin
  1124. eq:=compare_defs(hp.left.resultdef,hdef,hnodetype);
  1125. if eq>te_incompatible then
  1126. begin
  1127. hdef:=hp.left.resultdef;
  1128. hnodetype:=hp.left.nodetype;
  1129. end;
  1130. end
  1131. else
  1132. eq:=compare_defs(hdef,hp.left.resultdef,hp.left.nodetype);
  1133. if (not varia) and (eq<te_equal) then
  1134. begin
  1135. { If both are integers we need to take the type that can hold both
  1136. defs }
  1137. if is_integer(hdef) and is_integer(hp.left.resultdef) then
  1138. begin
  1139. if is_in_limit(hdef,hp.left.resultdef) then
  1140. hdef:=hp.left.resultdef;
  1141. end
  1142. else
  1143. if (nf_novariaallowed in flags) then
  1144. varia:=true;
  1145. end;
  1146. end;
  1147. inc(len);
  1148. hp:=tarrayconstructornode(hp.right);
  1149. end;
  1150. end;
  1151. { Set the type of empty or varia arrays to void. Also
  1152. do this if the type is array of const/open array
  1153. because those can't be used with setelementdef }
  1154. if not assigned(hdef) or
  1155. varia or
  1156. is_array_of_const(hdef) or
  1157. is_open_array(hdef) then
  1158. hdef:=voidtype;
  1159. resultdef:=carraydef.create(0,len-1,s32inttype);
  1160. tarraydef(resultdef).elementdef:=hdef;
  1161. include(tarraydef(resultdef).arrayoptions,ado_IsConstructor);
  1162. if varia then
  1163. include(tarraydef(resultdef).arrayoptions,ado_IsVariant);
  1164. end;
  1165. procedure tarrayconstructornode.force_type(def:tdef);
  1166. var
  1167. hp : tarrayconstructornode;
  1168. begin
  1169. tarraydef(resultdef).elementdef:=def;
  1170. include(tarraydef(resultdef).arrayoptions,ado_IsConstructor);
  1171. exclude(tarraydef(resultdef).arrayoptions,ado_IsVariant);
  1172. if assigned(left) then
  1173. begin
  1174. hp:=self;
  1175. while assigned(hp) do
  1176. begin
  1177. inserttypeconv(hp.left,def);
  1178. hp:=tarrayconstructornode(hp.right);
  1179. end;
  1180. end;
  1181. end;
  1182. procedure tarrayconstructornode.insert_typeconvs;
  1183. var
  1184. hp : tarrayconstructornode;
  1185. dovariant : boolean;
  1186. begin
  1187. dovariant:=(nf_forcevaria in flags) or (ado_isvariant in tarraydef(resultdef).arrayoptions);
  1188. { only pass left tree, right tree contains next construct if any }
  1189. if assigned(left) then
  1190. begin
  1191. hp:=self;
  1192. while assigned(hp) do
  1193. begin
  1194. typecheckpass(hp.left);
  1195. { Insert typeconvs for array of const }
  1196. if dovariant then
  1197. { at this time C varargs are no longer an arrayconstructornode }
  1198. insert_varargstypeconv(hp.left,false);
  1199. hp:=tarrayconstructornode(hp.right);
  1200. end;
  1201. end;
  1202. end;
  1203. function tarrayconstructornode.pass_1 : tnode;
  1204. var
  1205. hp : tarrayconstructornode;
  1206. do_variant,
  1207. do_managed_variant:boolean;
  1208. begin
  1209. do_variant:=(nf_forcevaria in flags) or (ado_isvariant in tarraydef(resultdef).arrayoptions);
  1210. do_managed_variant:=
  1211. do_variant and
  1212. (target_info.system in systems_managed_vm);
  1213. result:=nil;
  1214. { Insert required type convs, this must be
  1215. done in pass 1, because the call must be
  1216. typecheckpassed already }
  1217. if assigned(left) then
  1218. begin
  1219. insert_typeconvs;
  1220. { call firstpass for all nodes }
  1221. hp:=self;
  1222. while assigned(hp) do
  1223. begin
  1224. if hp.left<>nil then
  1225. begin
  1226. {This check is pessimistic; a call will happen depending
  1227. on the location in which the elements will be found in
  1228. pass 2.}
  1229. if not do_variant then
  1230. include(current_procinfo.flags,pi_do_call);
  1231. firstpass(hp.left);
  1232. if do_managed_variant then
  1233. wrapmanagedvarrec(hp.left);
  1234. end;
  1235. hp:=tarrayconstructornode(hp.right);
  1236. end;
  1237. end;
  1238. { set the elementdef to the correct type in case of a variant array }
  1239. if do_variant then
  1240. tarraydef(resultdef).elementdef:=search_system_type('TVARREC').typedef;
  1241. expectloc:=LOC_CREFERENCE;
  1242. end;
  1243. function tarrayconstructornode.docompare(p: tnode): boolean;
  1244. begin
  1245. docompare:=inherited docompare(p);
  1246. end;
  1247. {*****************************************************************************
  1248. TTYPENODE
  1249. *****************************************************************************}
  1250. constructor ttypenode.create(def:tdef);
  1251. begin
  1252. inherited create(typen);
  1253. typedef:=def;
  1254. typesym:=def.typesym;
  1255. allowed:=false;
  1256. helperallowed:=false;
  1257. end;
  1258. constructor ttypenode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  1259. begin
  1260. inherited ppuload(t,ppufile);
  1261. ppufile.getderef(typedefderef);
  1262. ppufile.getderef(typesymderef);
  1263. allowed:=boolean(ppufile.getbyte);
  1264. helperallowed:=boolean(ppufile.getbyte);
  1265. end;
  1266. procedure ttypenode.ppuwrite(ppufile:tcompilerppufile);
  1267. begin
  1268. inherited ppuwrite(ppufile);
  1269. ppufile.putderef(typedefderef);
  1270. ppufile.putderef(typesymderef);
  1271. ppufile.putbyte(byte(allowed));
  1272. ppufile.putbyte(byte(helperallowed));
  1273. end;
  1274. procedure ttypenode.buildderefimpl;
  1275. begin
  1276. inherited buildderefimpl;
  1277. typedefderef.build(typedef);
  1278. typesymderef.build(typesym);
  1279. end;
  1280. procedure ttypenode.derefimpl;
  1281. begin
  1282. inherited derefimpl;
  1283. typedef:=tdef(typedefderef.resolve);
  1284. typesym:=tsym(typesymderef.resolve);
  1285. end;
  1286. function ttypenode.pass_typecheck:tnode;
  1287. begin
  1288. result:=nil;
  1289. resultdef:=typedef;
  1290. { check if it's valid }
  1291. if typedef.typ = errordef then
  1292. CGMessage(parser_e_illegal_expression);
  1293. end;
  1294. function ttypenode.pass_1 : tnode;
  1295. begin
  1296. result:=nil;
  1297. expectloc:=LOC_VOID;
  1298. { a typenode can't generate code, so we give here
  1299. an error. Else it'll be an abstract error in pass_generate_code.
  1300. Only when the allowed flag is set we don't generate
  1301. an error }
  1302. if not allowed then
  1303. CGMessage(parser_e_no_type_not_allowed_here);
  1304. if not helperallowed and is_objectpascal_helper(typedef) then
  1305. CGMessage(parser_e_no_category_as_types);
  1306. end;
  1307. function ttypenode.dogetcopy : tnode;
  1308. var
  1309. n : ttypenode;
  1310. begin
  1311. n:=ttypenode(inherited dogetcopy);
  1312. n.allowed:=allowed;
  1313. n.typedef:=typedef;
  1314. n.helperallowed:=helperallowed;
  1315. result:=n;
  1316. end;
  1317. function ttypenode.docompare(p: tnode): boolean;
  1318. begin
  1319. docompare :=
  1320. inherited docompare(p) and
  1321. (typedef=ttypenode(p).typedef) and
  1322. (allowed=ttypenode(p).allowed) and
  1323. (helperallowed=ttypenode(p).helperallowed);
  1324. end;
  1325. {*****************************************************************************
  1326. TRTTINODE
  1327. *****************************************************************************}
  1328. constructor trttinode.create(def:tstoreddef;rt:trttitype;dt:Trttidatatype);
  1329. begin
  1330. inherited create(rttin);
  1331. rttidef:=def;
  1332. rttitype:=rt;
  1333. rttidatatype:=dt;
  1334. end;
  1335. constructor trttinode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  1336. begin
  1337. inherited ppuload(t,ppufile);
  1338. ppufile.getderef(rttidefderef);
  1339. rttitype:=trttitype(ppufile.getbyte);
  1340. rttidatatype:=trttidatatype(ppufile.getbyte);
  1341. end;
  1342. procedure trttinode.ppuwrite(ppufile:tcompilerppufile);
  1343. begin
  1344. inherited ppuwrite(ppufile);
  1345. ppufile.putderef(rttidefderef);
  1346. ppufile.putbyte(byte(rttitype));
  1347. ppufile.putbyte(byte(rttidatatype));
  1348. end;
  1349. procedure trttinode.buildderefimpl;
  1350. begin
  1351. inherited buildderefimpl;
  1352. rttidefderef.build(rttidef);
  1353. end;
  1354. procedure trttinode.derefimpl;
  1355. begin
  1356. inherited derefimpl;
  1357. rttidef:=tstoreddef(rttidefderef.resolve);
  1358. end;
  1359. function trttinode.dogetcopy : tnode;
  1360. var
  1361. n : trttinode;
  1362. begin
  1363. n:=trttinode(inherited dogetcopy);
  1364. n.rttidef:=rttidef;
  1365. n.rttitype:=rttitype;
  1366. n.rttidatatype:=rttidatatype;
  1367. result:=n;
  1368. end;
  1369. function trttinode.pass_typecheck:tnode;
  1370. begin
  1371. { rtti information will be returned as a void pointer }
  1372. result:=nil;
  1373. resultdef:=voidpointertype;
  1374. end;
  1375. function trttinode.pass_1 : tnode;
  1376. begin
  1377. result:=nil;
  1378. expectloc:=LOC_CREFERENCE;
  1379. if (cs_create_pic in current_settings.moduleswitches) and
  1380. (tf_pic_uses_got in target_info.flags) then
  1381. include(current_procinfo.flags,pi_needs_got);
  1382. end;
  1383. function trttinode.docompare(p: tnode): boolean;
  1384. begin
  1385. docompare :=
  1386. inherited docompare(p) and
  1387. (rttidef = trttinode(p).rttidef) and
  1388. (rttitype = trttinode(p).rttitype) and
  1389. (rttidatatype = trttinode(p).rttidatatype);
  1390. end;
  1391. end.