nld.pas 44 KB

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