nld.pas 43 KB

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