nld.pas 57 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512
  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. left,nil));
  512. 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. todo: for some integer types, there are extra implicit
  521. typecasts inserted by the compiler; this code should be
  522. updated to handle them as well }
  523. if (right.nodetype in [addn,subn,andn,orn,xorn]) and
  524. (taddnode(right).left.isequal(left)) and
  525. is_integer(taddnode(right).left.resultdef) and
  526. is_integer(taddnode(right).right.resultdef) and
  527. ((localswitches*[cs_check_overflow,cs_check_range])=[]) and
  528. ((right.localswitches*[cs_check_overflow,cs_check_range])=[]) and
  529. valid_for_var(taddnode(right).left,false) and
  530. not(might_have_sideeffects(taddnode(right).left)) then
  531. begin
  532. case right.nodetype of
  533. addn:
  534. newinlinenodetype:=in_inc_x;
  535. subn:
  536. newinlinenodetype:=in_dec_x;
  537. andn:
  538. newinlinenodetype:=in_and_assign_x_y;
  539. orn:
  540. newinlinenodetype:=in_or_assign_x_y;
  541. xorn:
  542. newinlinenodetype:=in_xor_assign_x_y;
  543. else
  544. internalerror(2017032901);
  545. end;
  546. if right.nodetype in [addn,subn] then
  547. result:=cinlinenode.createintern(
  548. newinlinenodetype,false,ccallparanode.create(
  549. left,ccallparanode.create(taddnode(right).right,nil)))
  550. else
  551. result:=cinlinenode.createintern(
  552. newinlinenodetype,false,ccallparanode.create(
  553. taddnode(right).right,ccallparanode.create(left,nil)));
  554. left:=nil;
  555. taddnode(right).right:=nil;
  556. exit;
  557. end;
  558. { replace i:=k+i by inc(i,k)
  559. i:=k and/or/xor i by in_[and/or/xor]_assign_x_y(i,k)
  560. todo: for some integer types, there are extra implicit
  561. typecasts inserted by the compiler; this code should be
  562. updated to handle them as well }
  563. if (right.nodetype in [addn,andn,orn,xorn]) and
  564. (taddnode(right).right.isequal(left)) and
  565. is_integer(taddnode(right).left.resultdef) and
  566. is_integer(taddnode(right).right.resultdef) and
  567. ((localswitches*[cs_check_overflow,cs_check_range])=[]) and
  568. ((right.localswitches*[cs_check_overflow,cs_check_range])=[]) and
  569. valid_for_var(taddnode(right).right,false) and
  570. not(might_have_sideeffects(taddnode(right).right)) then
  571. begin
  572. case right.nodetype of
  573. addn:
  574. newinlinenodetype:=in_inc_x;
  575. andn:
  576. newinlinenodetype:=in_and_assign_x_y;
  577. orn:
  578. newinlinenodetype:=in_or_assign_x_y;
  579. xorn:
  580. newinlinenodetype:=in_xor_assign_x_y;
  581. else
  582. internalerror(2017032902);
  583. end;
  584. if right.nodetype=addn then
  585. result:=cinlinenode.createintern(
  586. newinlinenodetype,false,ccallparanode.create(
  587. left,ccallparanode.create(taddnode(right).left,nil)))
  588. else
  589. result:=cinlinenode.createintern(
  590. newinlinenodetype,false,ccallparanode.create(
  591. taddnode(right).left,ccallparanode.create(left,nil)));
  592. left:=nil;
  593. taddnode(right).left:=nil;
  594. exit;
  595. end;
  596. { replace i:=not i by in_not_assign_x(i)
  597. i:=-i by in_neg_assign_x(i)
  598. this handles the case, where there are no implicit type conversions }
  599. if (right.nodetype in [notn,unaryminusn]) and
  600. (tunarynode(right).left.isequal(left)) and
  601. is_integer(tunarynode(right).left.resultdef) and
  602. ((localswitches*[cs_check_overflow,cs_check_range])=[]) and
  603. ((right.localswitches*[cs_check_overflow,cs_check_range])=[]) and
  604. valid_for_var(tunarynode(right).left,false) and
  605. not(might_have_sideeffects(tunarynode(right).left)) then
  606. begin
  607. if right.nodetype=notn then
  608. newinlinenodetype:=in_not_assign_x
  609. else
  610. newinlinenodetype:=in_neg_assign_x;
  611. result:=cinlinenode.createintern(
  612. newinlinenodetype,false,left);
  613. left:=nil;
  614. exit;
  615. end;
  616. { replace i:=not i by in_not_assign_x(i)
  617. i:=-i by in_neg_assign_x(i)
  618. this handles the case with type conversions:
  619. outer typeconv: right
  620. neg/not: ttypeconvnode(right).left
  621. inner typeconv: tunarynode(ttypeconvnode(right).left).left
  622. right side 'i': ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left }
  623. if (right.nodetype=typeconvn) and
  624. (ttypeconvnode(right).convtype=tc_int_2_int) and
  625. (ttypeconvnode(right).left.nodetype in [notn,unaryminusn]) and
  626. is_integer(ttypeconvnode(right).left.resultdef) and
  627. (right.resultdef.size<=ttypeconvnode(right).left.resultdef.size) and
  628. (tunarynode(ttypeconvnode(right).left).left.nodetype=typeconvn) and
  629. (ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).convtype=tc_int_2_int) and
  630. are_equal_ints(right.resultdef,ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left.resultdef) and
  631. ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left.isequal(left) and
  632. is_integer(ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left.resultdef) and
  633. ((localswitches*[cs_check_overflow,cs_check_range])=[]) and
  634. ((right.localswitches*[cs_check_overflow,cs_check_range])=[]) and
  635. valid_for_var(ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left,false) and
  636. not(might_have_sideeffects(ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left)) then
  637. begin
  638. if ttypeconvnode(right).left.nodetype=notn then
  639. newinlinenodetype:=in_not_assign_x
  640. else
  641. newinlinenodetype:=in_neg_assign_x;
  642. result:=cinlinenode.createintern(
  643. newinlinenodetype,false,left);
  644. left:=nil;
  645. exit;
  646. end;
  647. end;
  648. end;
  649. end;
  650. function tassignmentnode.pass_typecheck:tnode;
  651. var
  652. hp : tnode;
  653. useshelper : boolean;
  654. oldassignmentnode : tassignmentnode;
  655. begin
  656. result:=nil;
  657. resultdef:=voidtype;
  658. { must be made unique }
  659. set_unique(left);
  660. typecheckpass(left);
  661. { PI. This is needed to return correct resultdef of add nodes for ansistrings
  662. rawbytestring return needs to be replaced by left.resultdef }
  663. oldassignmentnode:=aktassignmentnode;
  664. aktassignmentnode:=self;
  665. typecheckpass(right);
  666. aktassignmentnode:=oldassignmentnode;
  667. set_varstate(right,vs_read,[vsf_must_be_valid]);
  668. set_varstate(left,vs_written,[]);
  669. if codegenerror then
  670. exit;
  671. { tp procvar support, when we don't expect a procvar
  672. then we need to call the procvar }
  673. if (left.resultdef.typ<>procvardef) then
  674. maybe_call_procvar(right,true);
  675. { assignments to formaldefs and open arrays aren't allowed }
  676. if is_open_array(left.resultdef) then
  677. CGMessage(type_e_assignment_not_allowed)
  678. else if (left.resultdef.typ=formaldef) then
  679. if not(target_info.system in systems_managed_vm) then
  680. CGMessage(type_e_assignment_not_allowed)
  681. else
  682. begin
  683. { on managed platforms, assigning to formaldefs is allowed (but
  684. typecasting them on the left hand side isn't), but primitive
  685. values need to be boxed first }
  686. if (right.resultdef.typ in [orddef,floatdef]) then
  687. begin
  688. right:=cinlinenode.create(in_box_x,false,ccallparanode.create(right,nil));
  689. typecheckpass(right);
  690. end;
  691. end;
  692. { test if node can be assigned, properties are allowed }
  693. if not(nf_internal in flags) then
  694. if not valid_for_assignment(left,true) then
  695. { errors can in situations that cause the compiler to run out of
  696. memory, such as assigning to an implicit pointer-to-array
  697. converted node (that array is 2^31 or 2^63 bytes large) }
  698. exit;
  699. { assigning nil to a dynamic array clears the array }
  700. if is_dynamic_array(left.resultdef) and
  701. (right.nodetype=niln) then
  702. begin
  703. { remove property flag to avoid errors, see comments for }
  704. { tf_winlikewidestring assignments below }
  705. exclude(left.flags,nf_isproperty);
  706. { generate a setlength node so it can be intercepted by
  707. target-specific code }
  708. result:=cinlinenode.create(in_setlength_x,false,
  709. ccallparanode.create(genintconstnode(0),
  710. ccallparanode.create(left,nil)));
  711. left:=nil;
  712. exit;
  713. end;
  714. { shortstring helpers can do the conversion directly,
  715. so treat them separatly }
  716. if (is_shortstring(left.resultdef)) then
  717. begin
  718. { insert typeconv, except for chars that are handled in
  719. secondpass and except for ansi/wide string that can
  720. be converted immediatly }
  721. if not direct_shortstring_assignment then
  722. inserttypeconv(right,left.resultdef);
  723. if right.resultdef.typ=stringdef then
  724. begin
  725. useshelper:=true;
  726. { convert constant strings to shortstrings. But
  727. skip empty constant strings, that will be handled
  728. in secondpass }
  729. if (right.nodetype=stringconstn) then
  730. begin
  731. { verify if range fits within shortstring }
  732. { just emit a warning, delphi gives an }
  733. { error, only if the type definition of }
  734. { of the string is less < 255 characters }
  735. if not is_open_string(left.resultdef) and
  736. (tstringconstnode(right).len > tstringdef(left.resultdef).len) then
  737. cgmessage(type_w_string_too_long);
  738. inserttypeconv(right,left.resultdef);
  739. if (right.nodetype=stringconstn) and
  740. (tstringconstnode(right).len=0) then
  741. useshelper:=false;
  742. end
  743. else if (tstringdef(right.resultdef).stringtype in [st_unicodestring,st_widestring]) then
  744. Message2(type_w_implicit_string_cast_loss,right.resultdef.typename,left.resultdef.typename);
  745. { rest is done in pass 1 (JM) }
  746. if useshelper then
  747. exit;
  748. end
  749. end
  750. { floating point assignments can also perform the conversion directly }
  751. else if is_real(left.resultdef) and is_real(right.resultdef) and
  752. not is_constrealnode(right)
  753. {$ifdef cpufpemu}
  754. { the emulator can't do this obviously }
  755. and not(current_settings.fputype in [fpu_libgcc,fpu_soft])
  756. {$endif cpufpemu}
  757. {$ifdef x86}
  758. { the assignment node code can't convert a double in an }
  759. { sse register to an extended value in memory more }
  760. { efficiently than a type conversion node, so don't }
  761. { bother implementing support for that }
  762. and (use_vectorfpu(left.resultdef) or not(use_vectorfpu(right.resultdef)))
  763. {$endif}
  764. {$ifdef arm}
  765. { the assignment node code can't convert a single in
  766. an interger register to a double in an mmregister or
  767. vice versa }
  768. and (use_vectorfpu(left.resultdef) and
  769. use_vectorfpu(right.resultdef) and
  770. (tfloatdef(left.resultdef).floattype=tfloatdef(right.resultdef).floattype))
  771. {$endif}
  772. then
  773. begin
  774. if not(nf_internal in flags) then
  775. check_ranges(fileinfo,right,left.resultdef);
  776. end
  777. else
  778. begin
  779. { check if the assignment may cause a range check error }
  780. if not(nf_internal in flags) then
  781. check_ranges(fileinfo,right,left.resultdef);
  782. { beginners might be confused about an error message like
  783. Incompatible types: got "untyped" expected "LongInt"
  784. when trying to assign the result of a procedure, so give
  785. a better error message, see also #19122 }
  786. if (left.resultdef.typ<>procvardef) and
  787. (right.nodetype=calln) and is_void(right.resultdef) then
  788. CGMessage(type_e_procedures_return_no_value)
  789. else if nf_internal in flags then
  790. inserttypeconv_internal(right,left.resultdef)
  791. else
  792. inserttypeconv(right,left.resultdef);
  793. end;
  794. { call helpers for interface }
  795. if is_interfacecom_or_dispinterface(left.resultdef) then
  796. begin
  797. { Normal interface assignments are handled by the generic refcount incr/decr }
  798. if not def_is_related(right.resultdef,left.resultdef) then
  799. begin
  800. { remove property flag to avoid errors, see comments for }
  801. { tf_winlikewidestring assignments below }
  802. exclude(left.flags,nf_isproperty);
  803. hp:=
  804. ccallparanode.create(
  805. cguidconstnode.create(tobjectdef(left.resultdef).iidguid^),
  806. ccallparanode.create(
  807. ctypeconvnode.create_internal(right,voidpointertype),
  808. ccallparanode.create(
  809. ctypeconvnode.create_internal(left,voidpointertype),
  810. nil)));
  811. result:=ccallnode.createintern('fpc_intf_assign_by_iid',hp);
  812. left:=nil;
  813. right:=nil;
  814. exit;
  815. end;
  816. end;
  817. { check if local proc/func is assigned to procvar }
  818. if right.resultdef.typ=procvardef then
  819. test_local_to_procvar(tprocvardef(right.resultdef),left.resultdef);
  820. end;
  821. function tassignmentnode.pass_1 : tnode;
  822. var
  823. hp: tnode;
  824. oldassignmentnode : tassignmentnode;
  825. hdef: tdef;
  826. hs: string;
  827. needrtti: boolean;
  828. begin
  829. result:=nil;
  830. expectloc:=LOC_VOID;
  831. firstpass(left);
  832. { Optimize the reuse of the destination of the assingment in left.
  833. Allow the use of the left inside the tree generated on the right.
  834. This is especially useful for string routines where the destination
  835. is pushed as a parameter. Using the final destination of left directly
  836. save a temp allocation and copy of data (PFV) }
  837. oldassignmentnode:=aktassignmentnode;
  838. aktassignmentnode:=self;
  839. firstpass(right);
  840. aktassignmentnode:=oldassignmentnode;
  841. if nf_assign_done_in_right in flags then
  842. begin
  843. result:=right;
  844. right:=nil;
  845. exit;
  846. end;
  847. if codegenerror then
  848. exit;
  849. { assignment to refcounted variable -> inc/decref }
  850. if is_managed_type(left.resultdef) then
  851. include(current_procinfo.flags,pi_do_call);
  852. needrtti:=false;
  853. if (is_shortstring(left.resultdef)) then
  854. begin
  855. if right.resultdef.typ=stringdef then
  856. begin
  857. if (right.nodetype<>stringconstn) or
  858. (tstringconstnode(right).len<>0) then
  859. begin
  860. { remove property flag to avoid errors, see comments for }
  861. { tf_winlikewidestring assignments below }
  862. exclude(left.flags, nf_isproperty);
  863. hp:=ccallparanode.create
  864. (right,
  865. ccallparanode.create(left,nil));
  866. result:=ccallnode.createintern('fpc_'+tstringdef(right.resultdef).stringtypname+'_to_shortstr',hp);
  867. firstpass(result);
  868. left:=nil;
  869. right:=nil;
  870. end;
  871. end;
  872. exit;
  873. end
  874. { call helpers for composite types containing automated types }
  875. else if is_managed_type(left.resultdef) and
  876. (left.resultdef.typ in [arraydef,objectdef,recorddef]) and
  877. not is_interfacecom_or_dispinterface(left.resultdef) and
  878. not is_dynamic_array(left.resultdef) and
  879. not is_const(left) and
  880. not(target_info.system in systems_garbage_collected_managed_types) then
  881. begin
  882. hp:=ccallparanode.create(caddrnode.create_internal(
  883. crttinode.create(tstoreddef(left.resultdef),initrtti,rdt_normal)),
  884. ccallparanode.create(ctypeconvnode.create_internal(
  885. caddrnode.create_internal(left),voidpointertype),
  886. ccallparanode.create(ctypeconvnode.create_internal(
  887. caddrnode.create_internal(right),voidpointertype),
  888. nil)));
  889. result:=ccallnode.createintern('fpc_copy_proc',hp);
  890. firstpass(result);
  891. left:=nil;
  892. right:=nil;
  893. exit;
  894. end
  895. { call helpers for variant, they can contain non ref. counted types like
  896. vararrays which must be really copied }
  897. else if (left.resultdef.typ=variantdef) and
  898. not(is_const(left)) and
  899. not(target_info.system in systems_garbage_collected_managed_types) then
  900. begin
  901. { remove property flag to avoid errors, see comments for }
  902. { tf_winlikewidestring assignments below }
  903. exclude(left.flags,nf_isproperty);
  904. hdef:=search_system_type('TVARDATA').typedef;
  905. hp:=ccallparanode.create(ctypeconvnode.create_internal(
  906. right,hdef),
  907. ccallparanode.create(ctypeconvnode.create_internal(
  908. left,hdef),
  909. nil));
  910. result:=ccallnode.createintern('fpc_variant_copy',hp);
  911. firstpass(result);
  912. left:=nil;
  913. right:=nil;
  914. exit;
  915. end
  916. else if not(target_info.system in systems_garbage_collected_managed_types) and
  917. not(is_const(left)) then
  918. begin
  919. { call helpers for pointer-sized managed types }
  920. if is_widestring(left.resultdef) then
  921. hs:='fpc_widestr_assign'
  922. else if is_ansistring(left.resultdef) then
  923. hs:='fpc_ansistr_assign'
  924. else if is_unicodestring(left.resultdef) then
  925. hs:='fpc_unicodestr_assign'
  926. else if is_interfacecom_or_dispinterface(left.resultdef) then
  927. hs:='fpc_intf_assign'
  928. else if is_dynamic_array(left.resultdef) then
  929. begin
  930. hs:='fpc_dynarray_assign';
  931. needrtti:=true;
  932. end
  933. else
  934. exit;
  935. end
  936. else
  937. exit;
  938. { The first argument of these procedures is a var parameter. Properties cannot }
  939. { be passed to var or out parameters, because in that case setters/getters are not }
  940. { used. Further, if we would allow it in case there are no getters or setters, you }
  941. { would need source changes in case these are introduced later on, thus defeating }
  942. { part of the transparency advantages of properties. In this particular case, }
  943. { however: }
  944. { a) if there is a setter, this code will not be used since then the assignment }
  945. { will be converted to a procedure call }
  946. { b) the getter is irrelevant, because fpc_widestr_assign must always decrease }
  947. { the refcount of the field to which we are writing }
  948. { c) source code changes are not required if a setter is added/removed, because }
  949. { this transformation is handled at compile time }
  950. { -> we can remove the nf_isproperty flag (if any) from left, so that in case it }
  951. { is a property which refers to a field without a setter call, we will not get }
  952. { an error about trying to pass a property as a var parameter }
  953. exclude(left.flags,nf_isproperty);
  954. hp:=ccallparanode.create(ctypeconvnode.create_internal(right,voidpointertype),
  955. ccallparanode.create(ctypeconvnode.create_internal(left,voidpointertype),
  956. nil));
  957. if needrtti then
  958. hp:=ccallparanode.create(
  959. caddrnode.create_internal(
  960. crttinode.create(tstoreddef(left.resultdef),initrtti,rdt_normal)),
  961. hp);
  962. result:=ccallnode.createintern(hs,hp);
  963. firstpass(result);
  964. left:=nil;
  965. right:=nil;
  966. end;
  967. function tassignmentnode.docompare(p: tnode): boolean;
  968. begin
  969. docompare :=
  970. inherited docompare(p) and
  971. (assigntype = tassignmentnode(p).assigntype);
  972. end;
  973. {$ifdef state_tracking}
  974. function Tassignmentnode.track_state_pass(exec_known:boolean):boolean;
  975. var se:Tstate_entry;
  976. begin
  977. track_state_pass:=false;
  978. if exec_known then
  979. begin
  980. track_state_pass:=right.track_state_pass(exec_known);
  981. {Force a new resultdef pass.}
  982. right.resultdef:=nil;
  983. do_typecheckpass(right);
  984. typecheckpass(right);
  985. aktstate.store_fact(left.getcopy,right.getcopy);
  986. end
  987. else
  988. aktstate.delete_fact(left);
  989. end;
  990. {$endif}
  991. {*****************************************************************************
  992. TARRAYCONSTRUCTORRANGENODE
  993. *****************************************************************************}
  994. constructor tarrayconstructorrangenode.create(l,r : tnode);
  995. begin
  996. inherited create(arrayconstructorrangen,l,r);
  997. end;
  998. function tarrayconstructorrangenode.pass_typecheck:tnode;
  999. begin
  1000. result:=nil;
  1001. typecheckpass(left);
  1002. typecheckpass(right);
  1003. set_varstate(left,vs_read,[vsf_must_be_valid]);
  1004. set_varstate(right,vs_read,[vsf_must_be_valid]);
  1005. if codegenerror then
  1006. exit;
  1007. resultdef:=left.resultdef;
  1008. end;
  1009. function tarrayconstructorrangenode.pass_1 : tnode;
  1010. begin
  1011. result:=nil;
  1012. CGMessage(parser_e_illegal_expression);
  1013. end;
  1014. {****************************************************************************
  1015. TARRAYCONSTRUCTORNODE
  1016. *****************************************************************************}
  1017. constructor tarrayconstructornode.create(l,r : tnode);
  1018. begin
  1019. inherited create(arrayconstructorn,l,r);
  1020. end;
  1021. function tarrayconstructornode.dogetcopy : tnode;
  1022. var
  1023. n : tarrayconstructornode;
  1024. begin
  1025. n:=tarrayconstructornode(inherited dogetcopy);
  1026. result:=n;
  1027. end;
  1028. function tarrayconstructornode.pass_typecheck:tnode;
  1029. var
  1030. hdef : tdef;
  1031. hp : tarrayconstructornode;
  1032. len : longint;
  1033. varia : boolean;
  1034. eq : tequaltype;
  1035. hnodetype : tnodetype;
  1036. begin
  1037. result:=nil;
  1038. { are we allowing array constructor? Then convert it to a set.
  1039. Do this only if we didn't convert the arrayconstructor yet. This
  1040. is needed for the cases where the resultdef is forced for a second
  1041. run }
  1042. if not(allow_array_constructor) then
  1043. begin
  1044. hp:=tarrayconstructornode(getcopy);
  1045. arrayconstructor_to_set(tnode(hp));
  1046. result:=hp;
  1047. exit;
  1048. end;
  1049. { only pass left tree, right tree contains next construct if any }
  1050. hdef:=nil;
  1051. hnodetype:=errorn;
  1052. len:=0;
  1053. varia:=false;
  1054. if assigned(left) then
  1055. begin
  1056. hp:=self;
  1057. while assigned(hp) do
  1058. begin
  1059. typecheckpass(hp.left);
  1060. set_varstate(hp.left,vs_read,[vsf_must_be_valid]);
  1061. if (hdef=nil) then
  1062. begin
  1063. hdef:=hp.left.resultdef;
  1064. hnodetype:=hp.left.nodetype;
  1065. end
  1066. else
  1067. begin
  1068. { If we got a niln we don't know the type yet and need to take the
  1069. type of the next array element.
  1070. This is to handle things like [nil,tclass,tclass], see also tw8371 (PFV) }
  1071. if hnodetype=niln then
  1072. begin
  1073. eq:=compare_defs(hp.left.resultdef,hdef,hnodetype);
  1074. if eq>te_incompatible then
  1075. begin
  1076. hdef:=hp.left.resultdef;
  1077. hnodetype:=hp.left.nodetype;
  1078. end;
  1079. end
  1080. else
  1081. eq:=compare_defs(hdef,hp.left.resultdef,hp.left.nodetype);
  1082. if (not varia) and (eq<te_equal) then
  1083. begin
  1084. { If both are integers we need to take the type that can hold both
  1085. defs }
  1086. if is_integer(hdef) and is_integer(hp.left.resultdef) then
  1087. begin
  1088. if is_in_limit(hdef,hp.left.resultdef) then
  1089. hdef:=hp.left.resultdef;
  1090. end
  1091. else
  1092. if (nf_novariaallowed in flags) then
  1093. varia:=true;
  1094. end;
  1095. end;
  1096. inc(len);
  1097. hp:=tarrayconstructornode(hp.right);
  1098. end;
  1099. end;
  1100. { Set the type of empty or varia arrays to void. Also
  1101. do this if the type is array of const/open array
  1102. because those can't be used with setelementdef }
  1103. if not assigned(hdef) or
  1104. varia or
  1105. is_array_of_const(hdef) or
  1106. is_open_array(hdef) then
  1107. hdef:=voidtype;
  1108. resultdef:=carraydef.create(0,len-1,s32inttype);
  1109. tarraydef(resultdef).elementdef:=hdef;
  1110. include(tarraydef(resultdef).arrayoptions,ado_IsConstructor);
  1111. if varia then
  1112. include(tarraydef(resultdef).arrayoptions,ado_IsVariant);
  1113. end;
  1114. procedure tarrayconstructornode.force_type(def:tdef);
  1115. var
  1116. hp : tarrayconstructornode;
  1117. begin
  1118. tarraydef(resultdef).elementdef:=def;
  1119. include(tarraydef(resultdef).arrayoptions,ado_IsConstructor);
  1120. exclude(tarraydef(resultdef).arrayoptions,ado_IsVariant);
  1121. if assigned(left) then
  1122. begin
  1123. hp:=self;
  1124. while assigned(hp) do
  1125. begin
  1126. inserttypeconv(hp.left,def);
  1127. hp:=tarrayconstructornode(hp.right);
  1128. end;
  1129. end;
  1130. end;
  1131. procedure tarrayconstructornode.insert_typeconvs;
  1132. var
  1133. hp : tarrayconstructornode;
  1134. dovariant : boolean;
  1135. begin
  1136. dovariant:=(nf_forcevaria in flags) or (ado_isvariant in tarraydef(resultdef).arrayoptions);
  1137. { only pass left tree, right tree contains next construct if any }
  1138. if assigned(left) then
  1139. begin
  1140. hp:=self;
  1141. while assigned(hp) do
  1142. begin
  1143. typecheckpass(hp.left);
  1144. { Insert typeconvs for array of const }
  1145. if dovariant then
  1146. { at this time C varargs are no longer an arrayconstructornode }
  1147. insert_varargstypeconv(hp.left,false);
  1148. hp:=tarrayconstructornode(hp.right);
  1149. end;
  1150. end;
  1151. end;
  1152. function tarrayconstructornode.pass_1 : tnode;
  1153. var
  1154. hp : tarrayconstructornode;
  1155. do_variant,
  1156. do_managed_variant:boolean;
  1157. begin
  1158. do_variant:=(nf_forcevaria in flags) or (ado_isvariant in tarraydef(resultdef).arrayoptions);
  1159. do_managed_variant:=
  1160. do_variant and
  1161. (target_info.system in systems_managed_vm);
  1162. result:=nil;
  1163. { Insert required type convs, this must be
  1164. done in pass 1, because the call must be
  1165. typecheckpassed already }
  1166. if assigned(left) then
  1167. begin
  1168. insert_typeconvs;
  1169. { call firstpass for all nodes }
  1170. hp:=self;
  1171. while assigned(hp) do
  1172. begin
  1173. if hp.left<>nil then
  1174. begin
  1175. {This check is pessimistic; a call will happen depending
  1176. on the location in which the elements will be found in
  1177. pass 2.}
  1178. if not do_variant then
  1179. include(current_procinfo.flags,pi_do_call);
  1180. firstpass(hp.left);
  1181. if do_managed_variant then
  1182. wrapmanagedvarrec(hp.left);
  1183. end;
  1184. hp:=tarrayconstructornode(hp.right);
  1185. end;
  1186. end;
  1187. { set the elementdef to the correct type in case of a variant array }
  1188. if do_variant then
  1189. tarraydef(resultdef).elementdef:=search_system_type('TVARREC').typedef;
  1190. expectloc:=LOC_CREFERENCE;
  1191. end;
  1192. function tarrayconstructornode.docompare(p: tnode): boolean;
  1193. begin
  1194. docompare:=inherited docompare(p);
  1195. end;
  1196. {*****************************************************************************
  1197. TTYPENODE
  1198. *****************************************************************************}
  1199. constructor ttypenode.create(def:tdef);
  1200. begin
  1201. inherited create(typen);
  1202. typedef:=def;
  1203. typesym:=def.typesym;
  1204. allowed:=false;
  1205. helperallowed:=false;
  1206. end;
  1207. constructor ttypenode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  1208. begin
  1209. inherited ppuload(t,ppufile);
  1210. ppufile.getderef(typedefderef);
  1211. ppufile.getderef(typesymderef);
  1212. allowed:=boolean(ppufile.getbyte);
  1213. helperallowed:=boolean(ppufile.getbyte);
  1214. end;
  1215. procedure ttypenode.ppuwrite(ppufile:tcompilerppufile);
  1216. begin
  1217. inherited ppuwrite(ppufile);
  1218. ppufile.putderef(typedefderef);
  1219. ppufile.putderef(typesymderef);
  1220. ppufile.putbyte(byte(allowed));
  1221. ppufile.putbyte(byte(helperallowed));
  1222. end;
  1223. procedure ttypenode.buildderefimpl;
  1224. begin
  1225. inherited buildderefimpl;
  1226. typedefderef.build(typedef);
  1227. typesymderef.build(typesym);
  1228. end;
  1229. procedure ttypenode.derefimpl;
  1230. begin
  1231. inherited derefimpl;
  1232. typedef:=tdef(typedefderef.resolve);
  1233. typesym:=tsym(typesymderef.resolve);
  1234. end;
  1235. function ttypenode.pass_typecheck:tnode;
  1236. begin
  1237. result:=nil;
  1238. resultdef:=typedef;
  1239. { check if it's valid }
  1240. if typedef.typ = errordef then
  1241. CGMessage(parser_e_illegal_expression);
  1242. end;
  1243. function ttypenode.pass_1 : tnode;
  1244. begin
  1245. result:=nil;
  1246. expectloc:=LOC_VOID;
  1247. { a typenode can't generate code, so we give here
  1248. an error. Else it'll be an abstract error in pass_generate_code.
  1249. Only when the allowed flag is set we don't generate
  1250. an error }
  1251. if not allowed then
  1252. CGMessage(parser_e_no_type_not_allowed_here);
  1253. if not helperallowed and is_objectpascal_helper(typedef) then
  1254. CGMessage(parser_e_no_category_as_types);
  1255. end;
  1256. function ttypenode.dogetcopy : tnode;
  1257. var
  1258. n : ttypenode;
  1259. begin
  1260. n:=ttypenode(inherited dogetcopy);
  1261. n.allowed:=allowed;
  1262. n.typedef:=typedef;
  1263. n.helperallowed:=helperallowed;
  1264. result:=n;
  1265. end;
  1266. function ttypenode.docompare(p: tnode): boolean;
  1267. begin
  1268. docompare :=
  1269. inherited docompare(p) and
  1270. (typedef=ttypenode(p).typedef) and
  1271. (allowed=ttypenode(p).allowed) and
  1272. (helperallowed=ttypenode(p).helperallowed);
  1273. end;
  1274. {*****************************************************************************
  1275. TRTTINODE
  1276. *****************************************************************************}
  1277. constructor trttinode.create(def:tstoreddef;rt:trttitype;dt:Trttidatatype);
  1278. begin
  1279. inherited create(rttin);
  1280. rttidef:=def;
  1281. rttitype:=rt;
  1282. rttidatatype:=dt;
  1283. end;
  1284. constructor trttinode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  1285. begin
  1286. inherited ppuload(t,ppufile);
  1287. ppufile.getderef(rttidefderef);
  1288. rttitype:=trttitype(ppufile.getbyte);
  1289. rttidatatype:=trttidatatype(ppufile.getbyte);
  1290. end;
  1291. procedure trttinode.ppuwrite(ppufile:tcompilerppufile);
  1292. begin
  1293. inherited ppuwrite(ppufile);
  1294. ppufile.putderef(rttidefderef);
  1295. ppufile.putbyte(byte(rttitype));
  1296. ppufile.putbyte(byte(rttidatatype));
  1297. end;
  1298. procedure trttinode.buildderefimpl;
  1299. begin
  1300. inherited buildderefimpl;
  1301. rttidefderef.build(rttidef);
  1302. end;
  1303. procedure trttinode.derefimpl;
  1304. begin
  1305. inherited derefimpl;
  1306. rttidef:=tstoreddef(rttidefderef.resolve);
  1307. end;
  1308. function trttinode.dogetcopy : tnode;
  1309. var
  1310. n : trttinode;
  1311. begin
  1312. n:=trttinode(inherited dogetcopy);
  1313. n.rttidef:=rttidef;
  1314. n.rttitype:=rttitype;
  1315. n.rttidatatype:=rttidatatype;
  1316. result:=n;
  1317. end;
  1318. function trttinode.pass_typecheck:tnode;
  1319. begin
  1320. { rtti information will be returned as a void pointer }
  1321. result:=nil;
  1322. resultdef:=voidpointertype;
  1323. end;
  1324. function trttinode.pass_1 : tnode;
  1325. begin
  1326. result:=nil;
  1327. expectloc:=LOC_CREFERENCE;
  1328. if (cs_create_pic in current_settings.moduleswitches) and
  1329. (tf_pic_uses_got in target_info.flags) then
  1330. include(current_procinfo.flags,pi_needs_got);
  1331. end;
  1332. function trttinode.docompare(p: tnode): boolean;
  1333. begin
  1334. docompare :=
  1335. inherited docompare(p) and
  1336. (rttidef = trttinode(p).rttidef) and
  1337. (rttitype = trttinode(p).rttitype) and
  1338. (rttidatatype = trttinode(p).rttidatatype);
  1339. end;
  1340. end.