nmem.pas 29 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945
  1. {
  2. Copyright (c) 2000-2002 by Florian Klaempfl
  3. Type checking and register allocation for memory related 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 nmem;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. node,
  22. symdef,symsym,symtable,symtype;
  23. type
  24. tloadvmtaddrnode = class(tunarynode)
  25. constructor create(l : tnode);virtual;
  26. function pass_1 : tnode;override;
  27. function det_resulttype:tnode;override;
  28. end;
  29. tloadvmtaddrnodeclass = class of tloadvmtaddrnode;
  30. tloadparentfpnode = class(tunarynode)
  31. parentpd : tprocdef;
  32. parentpdderef : tderef;
  33. constructor create(pd:tprocdef);virtual;
  34. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  35. procedure ppuwrite(ppufile:tcompilerppufile);override;
  36. procedure buildderefimpl;override;
  37. procedure derefimpl;override;
  38. function pass_1 : tnode;override;
  39. function det_resulttype:tnode;override;
  40. function _getcopy : tnode;override;
  41. end;
  42. tloadparentfpnodeclass = class of tloadparentfpnode;
  43. taddrnode = class(tunarynode)
  44. getprocvardef : tprocvardef;
  45. getprocvardefderef : tderef;
  46. constructor create(l : tnode);virtual;
  47. constructor create_internal(l : tnode); virtual;
  48. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  49. procedure ppuwrite(ppufile:tcompilerppufile);override;
  50. procedure mark_write;override;
  51. procedure buildderefimpl;override;
  52. procedure derefimpl;override;
  53. function _getcopy : tnode;override;
  54. function pass_1 : tnode;override;
  55. function det_resulttype:tnode;override;
  56. end;
  57. taddrnodeclass = class of taddrnode;
  58. tderefnode = class(tunarynode)
  59. constructor create(l : tnode);virtual;
  60. function pass_1 : tnode;override;
  61. function det_resulttype:tnode;override;
  62. procedure mark_write;override;
  63. end;
  64. tderefnodeclass = class of tderefnode;
  65. tsubscriptnode = class(tunarynode)
  66. vs : tfieldvarsym;
  67. vsderef : tderef;
  68. constructor create(varsym : tsym;l : tnode);virtual;
  69. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  70. procedure ppuwrite(ppufile:tcompilerppufile);override;
  71. procedure buildderefimpl;override;
  72. procedure derefimpl;override;
  73. function _getcopy : tnode;override;
  74. function pass_1 : tnode;override;
  75. function docompare(p: tnode): boolean; override;
  76. function det_resulttype:tnode;override;
  77. procedure mark_write;override;
  78. end;
  79. tsubscriptnodeclass = class of tsubscriptnode;
  80. tvecnode = class(tbinarynode)
  81. constructor create(l,r : tnode);virtual;
  82. function pass_1 : tnode;override;
  83. function det_resulttype:tnode;override;
  84. procedure mark_write;override;
  85. end;
  86. tvecnodeclass = class of tvecnode;
  87. twithnode = class(tunarynode)
  88. constructor create(l:tnode);
  89. destructor destroy;override;
  90. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  91. procedure ppuwrite(ppufile:tcompilerppufile);override;
  92. function _getcopy : tnode;override;
  93. function pass_1 : tnode;override;
  94. function docompare(p: tnode): boolean; override;
  95. function det_resulttype:tnode;override;
  96. end;
  97. twithnodeclass = class of twithnode;
  98. var
  99. cloadvmtaddrnode : tloadvmtaddrnodeclass;
  100. cloadparentfpnode : tloadparentfpnodeclass;
  101. caddrnode : taddrnodeclass;
  102. cderefnode : tderefnodeclass;
  103. csubscriptnode : tsubscriptnodeclass;
  104. cvecnode : tvecnodeclass;
  105. cwithnode : twithnodeclass;
  106. implementation
  107. uses
  108. globtype,systems,
  109. cutils,verbose,globals,
  110. symconst,symbase,defutil,defcmp,
  111. nbas,nutils,
  112. htypechk,pass_1,ncal,nld,ncon,ncnv,cgbase,procinfo
  113. ;
  114. {*****************************************************************************
  115. TLOADVMTADDRNODE
  116. *****************************************************************************}
  117. constructor tloadvmtaddrnode.create(l : tnode);
  118. begin
  119. inherited create(loadvmtaddrn,l);
  120. end;
  121. function tloadvmtaddrnode.det_resulttype:tnode;
  122. begin
  123. result:=nil;
  124. resulttypepass(left);
  125. if codegenerror then
  126. exit;
  127. case left.resulttype.def.deftype of
  128. classrefdef :
  129. resulttype:=left.resulttype;
  130. objectdef :
  131. resulttype.setdef(tclassrefdef.create(left.resulttype));
  132. else
  133. Message(parser_e_pointer_to_class_expected);
  134. end;
  135. end;
  136. function tloadvmtaddrnode.pass_1 : tnode;
  137. begin
  138. result:=nil;
  139. expectloc:=LOC_REGISTER;
  140. if left.nodetype<>typen then
  141. begin
  142. firstpass(left);
  143. registersint:=left.registersint;
  144. end;
  145. if registersint<1 then
  146. registersint:=1;
  147. end;
  148. {*****************************************************************************
  149. TLOADPARENTFPNODE
  150. *****************************************************************************}
  151. constructor tloadparentfpnode.create(pd:tprocdef);
  152. begin
  153. inherited create(loadparentfpn,nil);
  154. if not assigned(pd) then
  155. internalerror(200309288);
  156. if (pd.parast.symtablelevel>current_procinfo.procdef.parast.symtablelevel) then
  157. internalerror(200309284);
  158. parentpd:=pd;
  159. end;
  160. constructor tloadparentfpnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  161. begin
  162. inherited ppuload(t,ppufile);
  163. ppufile.getderef(parentpdderef);
  164. end;
  165. procedure tloadparentfpnode.ppuwrite(ppufile:tcompilerppufile);
  166. begin
  167. inherited ppuwrite(ppufile);
  168. ppufile.putderef(parentpdderef);
  169. end;
  170. procedure tloadparentfpnode.buildderefimpl;
  171. begin
  172. inherited buildderefimpl;
  173. parentpdderef.build(parentpd);
  174. end;
  175. procedure tloadparentfpnode.derefimpl;
  176. begin
  177. inherited derefimpl;
  178. parentpd:=tprocdef(parentpdderef.resolve);
  179. end;
  180. function tloadparentfpnode._getcopy : tnode;
  181. var
  182. p : tloadparentfpnode;
  183. begin
  184. p:=tloadparentfpnode(inherited _getcopy);
  185. p.parentpd:=parentpd;
  186. _getcopy:=p;
  187. end;
  188. function tloadparentfpnode.det_resulttype:tnode;
  189. {$ifdef dummy}
  190. var
  191. currpi : tprocinfo;
  192. hsym : tparavarsym;
  193. {$endif dummy}
  194. begin
  195. result:=nil;
  196. resulttype:=voidpointertype;
  197. {$ifdef dummy}
  198. { currently parentfps are never loaded in registers (FK) }
  199. if (current_procinfo.procdef.parast.symtablelevel<>parentpd.parast.symtablelevel) then
  200. begin
  201. currpi:=current_procinfo;
  202. { walk parents }
  203. while (currpi.procdef.owner.symtablelevel>parentpd.parast.symtablelevel) do
  204. begin
  205. currpi:=currpi.parent;
  206. if not assigned(currpi) then
  207. internalerror(2005040602);
  208. hsym:=tparavarsym(currpi.procdef.parast.search('parentfp'));
  209. if not assigned(hsym) then
  210. internalerror(2005040601);
  211. hsym.varregable:=vr_none;
  212. end;
  213. end;
  214. {$endif dummy}
  215. end;
  216. function tloadparentfpnode.pass_1 : tnode;
  217. begin
  218. result:=nil;
  219. expectloc:=LOC_REGISTER;
  220. registersint:=1;
  221. end;
  222. {*****************************************************************************
  223. TADDRNODE
  224. *****************************************************************************}
  225. constructor taddrnode.create(l : tnode);
  226. begin
  227. inherited create(addrn,l);
  228. getprocvardef:=nil;
  229. end;
  230. constructor taddrnode.create_internal(l : tnode);
  231. begin
  232. self.create(l);
  233. include(flags,nf_internal);
  234. end;
  235. constructor taddrnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  236. begin
  237. inherited ppuload(t,ppufile);
  238. ppufile.getderef(getprocvardefderef);
  239. end;
  240. procedure taddrnode.ppuwrite(ppufile:tcompilerppufile);
  241. begin
  242. inherited ppuwrite(ppufile);
  243. ppufile.putderef(getprocvardefderef);
  244. end;
  245. procedure Taddrnode.mark_write;
  246. begin
  247. {@procvar:=nil is legal in Delphi mode.}
  248. left.mark_write;
  249. end;
  250. procedure taddrnode.buildderefimpl;
  251. begin
  252. inherited buildderefimpl;
  253. getprocvardefderef.build(getprocvardef);
  254. end;
  255. procedure taddrnode.derefimpl;
  256. begin
  257. inherited derefimpl;
  258. getprocvardef:=tprocvardef(getprocvardefderef.resolve);
  259. end;
  260. function taddrnode._getcopy : tnode;
  261. var
  262. p : taddrnode;
  263. begin
  264. p:=taddrnode(inherited _getcopy);
  265. p.getprocvardef:=getprocvardef;
  266. _getcopy:=p;
  267. end;
  268. function taddrnode.det_resulttype:tnode;
  269. var
  270. hp : tnode;
  271. hsym : tfieldvarsym;
  272. isprocvar : boolean;
  273. begin
  274. result:=nil;
  275. resulttypepass(left);
  276. if codegenerror then
  277. exit;
  278. make_not_regable(left,vr_addr);
  279. { don't allow constants, for internal use we also
  280. allow taking the address of strings }
  281. if is_constnode(left) and
  282. not(
  283. (nf_internal in flags) and
  284. (left.nodetype in [stringconstn])
  285. ) then
  286. begin
  287. aktfilepos:=left.fileinfo;
  288. CGMessage(type_e_no_addr_of_constant);
  289. exit;
  290. end;
  291. { Handle @proc special, also @procvar in tp-mode needs
  292. special handling }
  293. if (left.resulttype.def.deftype=procdef) or
  294. (
  295. (left.resulttype.def.deftype=procvardef) and
  296. ((m_tp_procvar in aktmodeswitches) or
  297. (m_mac_procvar in aktmodeswitches))
  298. ) then
  299. begin
  300. isprocvar:=(left.resulttype.def.deftype=procvardef);
  301. if not isprocvar then
  302. begin
  303. left:=ctypeconvnode.create_proc_to_procvar(left);
  304. resulttypepass(left);
  305. end;
  306. { In tp procvar mode the result is always a voidpointer. Insert
  307. a typeconversion to voidpointer. For methodpointers we need
  308. to load the proc field }
  309. if (m_tp_procvar in aktmodeswitches) or
  310. (m_mac_procvar in aktmodeswitches) then
  311. begin
  312. if tabstractprocdef(left.resulttype.def).is_addressonly then
  313. begin
  314. result:=ctypeconvnode.create_internal(left,voidpointertype);
  315. include(result.flags,nf_load_procvar);
  316. left:=nil;
  317. end
  318. else
  319. begin
  320. { For procvars we need to return the proc field of the
  321. methodpointer }
  322. if isprocvar then
  323. begin
  324. { find proc field in methodpointer record }
  325. hsym:=tfieldvarsym(trecorddef(methodpointertype.def).symtable.search('proc'));
  326. if not assigned(hsym) then
  327. internalerror(200412041);
  328. { Load tmehodpointer(left).proc }
  329. result:=csubscriptnode.create(
  330. hsym,
  331. ctypeconvnode.create_internal(left,methodpointertype));
  332. left:=nil;
  333. end
  334. else
  335. CGMessage(type_e_variable_id_expected);
  336. end;
  337. end
  338. else
  339. begin
  340. { Return the typeconvn only }
  341. result:=left;
  342. left:=nil;
  343. end;
  344. end
  345. else
  346. begin
  347. { what are we getting the address from an absolute sym? }
  348. hp:=left;
  349. while assigned(hp) and (hp.nodetype in [typeconvn,vecn,derefn,subscriptn]) do
  350. hp:=tunarynode(hp).left;
  351. if not assigned(hp) then
  352. internalerror(200412042);
  353. {$ifdef i386}
  354. if (hp.nodetype=loadn) and
  355. ((tloadnode(hp).symtableentry.typ=absolutevarsym) and
  356. tabsolutevarsym(tloadnode(hp).symtableentry).absseg) then
  357. begin
  358. if not(nf_typedaddr in flags) then
  359. resulttype:=voidfarpointertype
  360. else
  361. resulttype.setdef(tpointerdef.createfar(left.resulttype));
  362. end
  363. else
  364. {$endif i386}
  365. if (nf_internal in flags) or
  366. valid_for_addr(left,true) then
  367. begin
  368. if not(nf_typedaddr in flags) then
  369. resulttype:=voidpointertype
  370. else
  371. resulttype.setdef(tpointerdef.create(left.resulttype));
  372. end
  373. else
  374. CGMessage(type_e_variable_id_expected);
  375. end;
  376. { this is like the function addr }
  377. inc(parsing_para_level);
  378. { This is actually only "read", but treat it nevertheless as }
  379. { modified due to the possible use of pointers }
  380. { To avoid false positives regarding "uninitialised" }
  381. { warnings when using arrays, perform it in two steps }
  382. set_varstate(left,vs_written,[]);
  383. set_varstate(left,vs_read,[]);
  384. dec(parsing_para_level);
  385. end;
  386. function taddrnode.pass_1 : tnode;
  387. begin
  388. result:=nil;
  389. firstpass(left);
  390. if codegenerror then
  391. exit;
  392. registersint:=left.registersint;
  393. registersfpu:=left.registersfpu;
  394. {$ifdef SUPPORT_MMX}
  395. registersmmx:=left.registersmmx;
  396. {$endif SUPPORT_MMX}
  397. if registersint<1 then
  398. registersint:=1;
  399. { is this right for object of methods ?? }
  400. expectloc:=LOC_REGISTER;
  401. end;
  402. {*****************************************************************************
  403. TDEREFNODE
  404. *****************************************************************************}
  405. constructor tderefnode.create(l : tnode);
  406. begin
  407. inherited create(derefn,l);
  408. end;
  409. function tderefnode.det_resulttype:tnode;
  410. begin
  411. result:=nil;
  412. resulttypepass(left);
  413. set_varstate(left,vs_read,[vsf_must_be_valid]);
  414. if codegenerror then
  415. exit;
  416. { tp procvar support }
  417. maybe_call_procvar(left,true);
  418. if left.resulttype.def.deftype=pointerdef then
  419. resulttype:=tpointerdef(left.resulttype.def).pointertype
  420. else
  421. CGMessage(parser_e_invalid_qualifier);
  422. end;
  423. procedure Tderefnode.mark_write;
  424. begin
  425. include(flags,nf_write);
  426. end;
  427. function tderefnode.pass_1 : tnode;
  428. begin
  429. result:=nil;
  430. firstpass(left);
  431. if codegenerror then
  432. exit;
  433. registersint:=max(left.registersint,1);
  434. registersfpu:=left.registersfpu;
  435. {$ifdef SUPPORT_MMX}
  436. registersmmx:=left.registersmmx;
  437. {$endif SUPPORT_MMX}
  438. expectloc:=LOC_REFERENCE;
  439. end;
  440. {*****************************************************************************
  441. TSUBSCRIPTNODE
  442. *****************************************************************************}
  443. constructor tsubscriptnode.create(varsym : tsym;l : tnode);
  444. begin
  445. inherited create(subscriptn,l);
  446. { vs should be changed to tsym! }
  447. vs:=tfieldvarsym(varsym);
  448. end;
  449. constructor tsubscriptnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  450. begin
  451. inherited ppuload(t,ppufile);
  452. ppufile.getderef(vsderef);
  453. end;
  454. procedure tsubscriptnode.ppuwrite(ppufile:tcompilerppufile);
  455. begin
  456. inherited ppuwrite(ppufile);
  457. ppufile.putderef(vsderef);
  458. end;
  459. procedure tsubscriptnode.buildderefimpl;
  460. begin
  461. inherited buildderefimpl;
  462. vsderef.build(vs);
  463. end;
  464. procedure tsubscriptnode.derefimpl;
  465. begin
  466. inherited derefimpl;
  467. vs:=tfieldvarsym(vsderef.resolve);
  468. end;
  469. function tsubscriptnode._getcopy : tnode;
  470. var
  471. p : tsubscriptnode;
  472. begin
  473. p:=tsubscriptnode(inherited _getcopy);
  474. p.vs:=vs;
  475. _getcopy:=p;
  476. end;
  477. function tsubscriptnode.det_resulttype:tnode;
  478. begin
  479. result:=nil;
  480. resulttypepass(left);
  481. { tp procvar support }
  482. maybe_call_procvar(left,true);
  483. resulttype:=vs.vartype;
  484. // don't put records from which we load fields which aren't regable in integer registers
  485. if (left.resulttype.def.deftype = recorddef) and
  486. not(tstoreddef(resulttype.def).is_intregable) then
  487. make_not_regable(left,vr_addr);
  488. end;
  489. procedure Tsubscriptnode.mark_write;
  490. begin
  491. include(flags,nf_write);
  492. end;
  493. function tsubscriptnode.pass_1 : tnode;
  494. begin
  495. result:=nil;
  496. firstpass(left);
  497. if codegenerror then
  498. exit;
  499. registersint:=left.registersint;
  500. registersfpu:=left.registersfpu;
  501. {$ifdef SUPPORT_MMX}
  502. registersmmx:=left.registersmmx;
  503. {$endif SUPPORT_MMX}
  504. { classes must be dereferenced implicit }
  505. if is_class_or_interface(left.resulttype.def) then
  506. begin
  507. if registersint=0 then
  508. registersint:=1;
  509. expectloc:=LOC_REFERENCE;
  510. end
  511. else
  512. begin
  513. case left.expectloc of
  514. LOC_REGISTER,
  515. LOC_SUBSETREG:
  516. // can happen for function results on win32 and darwin/x86
  517. if (left.resulttype.def.size > sizeof(aint)) then
  518. expectloc:=LOC_REFERENCE
  519. else
  520. expectloc:=LOC_SUBSETREG;
  521. LOC_CREGISTER,
  522. LOC_CSUBSETREG:
  523. expectloc:=LOC_CSUBSETREG;
  524. LOC_REFERENCE,
  525. LOC_CREFERENCE:
  526. expectloc:=left.expectloc;
  527. else internalerror(20060521);
  528. end;
  529. end;
  530. end;
  531. function tsubscriptnode.docompare(p: tnode): boolean;
  532. begin
  533. docompare :=
  534. inherited docompare(p) and
  535. (vs = tsubscriptnode(p).vs);
  536. end;
  537. {*****************************************************************************
  538. TVECNODE
  539. *****************************************************************************}
  540. constructor tvecnode.create(l,r : tnode);
  541. begin
  542. inherited create(vecn,l,r);
  543. end;
  544. function tvecnode.det_resulttype:tnode;
  545. var
  546. htype : ttype;
  547. valid : boolean;
  548. begin
  549. result:=nil;
  550. resulttypepass(left);
  551. resulttypepass(right);
  552. { implicitly convert stringconstant to stringdef,
  553. see tbs/tb0476.pp for a test }
  554. if (left.nodetype=stringconstn) and
  555. (tstringconstnode(left).cst_type=cst_conststring) then
  556. begin
  557. if tstringconstnode(left).len>255 then
  558. inserttypeconv(left,cansistringtype)
  559. else
  560. inserttypeconv(left,cshortstringtype);
  561. end;
  562. { In p[1] p is always valid, it is not possible to
  563. declared a shortstring or normal array that has
  564. undefined number of elements. Dynamic array and
  565. ansi/widestring needs to be valid }
  566. valid:=is_dynamic_array(left.resulttype.def) or
  567. is_ansistring(left.resulttype.def) or
  568. is_widestring(left.resulttype.def) or
  569. { implicit pointer dereference -> pointer is read }
  570. (left.resulttype.def.deftype = pointerdef);
  571. if valid then
  572. set_varstate(left,vs_read,[vsf_must_be_valid]);
  573. {
  574. A vecn is, just like a loadn, always part of an expression with its
  575. own read/write and must_be_valid semantics. Therefore we don't have
  576. to do anything else here, just like for loadn's
  577. }
  578. set_varstate(right,vs_read,[vsf_must_be_valid]);
  579. if codegenerror then
  580. exit;
  581. { maybe type conversion for the index value, but
  582. do not convert enums,booleans,char }
  583. if ((right.resulttype.def.deftype<>enumdef) and
  584. not(is_char(right.resulttype.def) or is_widechar(right.resulttype.def)) and
  585. not(is_boolean(right.resulttype.def))) or
  586. (left.resulttype.def.deftype <> arraydef) then
  587. begin
  588. inserttypeconv(right,sinttype);
  589. end;
  590. case left.resulttype.def.deftype of
  591. arraydef :
  592. begin
  593. { check type of the index value }
  594. if (compare_defs(right.resulttype.def,tarraydef(left.resulttype.def).rangetype.def,right.nodetype)=te_incompatible) then
  595. IncompatibleTypes(right.resulttype.def,tarraydef(left.resulttype.def).rangetype.def);
  596. resulttype:=tarraydef(left.resulttype.def).elementtype;
  597. end;
  598. pointerdef :
  599. begin
  600. { are we accessing a pointer[], then convert the pointer to
  601. an array first, in FPC this is allowed for all pointers
  602. (except voidpointer) in delphi/tp7 it's only allowed for pchars. }
  603. if not is_voidpointer(left.resulttype.def) and
  604. (
  605. (m_fpc in aktmodeswitches) or
  606. is_pchar(left.resulttype.def) or
  607. is_pwidechar(left.resulttype.def)
  608. ) then
  609. begin
  610. { convert pointer to array }
  611. htype.setdef(tarraydef.create_from_pointer(tpointerdef(left.resulttype.def).pointertype));
  612. inserttypeconv(left,htype);
  613. resulttype:=tarraydef(htype.def).elementtype;
  614. end
  615. else
  616. CGMessage(type_e_array_required);
  617. end;
  618. stringdef :
  619. begin
  620. { indexed access to 0 element is only allowed for shortstrings }
  621. if (right.nodetype=ordconstn) and
  622. (tordconstnode(right).value=0) and
  623. not(is_shortstring(left.resulttype.def)) then
  624. CGMessage(cg_e_can_access_element_zero);
  625. case tstringdef(left.resulttype.def).string_typ of
  626. st_widestring :
  627. resulttype:=cwidechartype;
  628. st_ansistring :
  629. resulttype:=cchartype;
  630. st_longstring :
  631. resulttype:=cchartype;
  632. st_shortstring :
  633. resulttype:=cchartype;
  634. end;
  635. end;
  636. variantdef :
  637. resulttype:=cvarianttype;
  638. else
  639. CGMessage(type_e_array_required);
  640. end;
  641. end;
  642. procedure Tvecnode.mark_write;
  643. begin
  644. include(flags,nf_write);
  645. end;
  646. function tvecnode.pass_1 : tnode;
  647. {$ifdef consteval}
  648. var
  649. tcsym : ttypedconstsym;
  650. {$endif}
  651. begin
  652. result:=nil;
  653. firstpass(left);
  654. firstpass(right);
  655. if codegenerror then
  656. exit;
  657. if (nf_callunique in flags) and
  658. (is_ansistring(left.resulttype.def) or
  659. (is_widestring(left.resulttype.def) and not(tf_winlikewidestring in target_info.flags))) then
  660. begin
  661. left := ctypeconvnode.create_internal(ccallnode.createintern('fpc_'+tstringdef(left.resulttype.def).stringtypname+'_unique',
  662. ccallparanode.create(
  663. ctypeconvnode.create_internal(left,voidpointertype),nil)),
  664. left.resulttype);
  665. firstpass(left);
  666. { double resulttype passes somwhere else may cause this to be }
  667. { reset though :/ }
  668. exclude(flags,nf_callunique);
  669. end
  670. else if is_widestring(left.resulttype.def) and (tf_winlikewidestring in target_info.flags) then
  671. exclude(flags,nf_callunique);
  672. { the register calculation is easy if a const index is used }
  673. if right.nodetype=ordconstn then
  674. begin
  675. {$ifdef consteval}
  676. { constant evaluation }
  677. if (left.nodetype=loadn) and
  678. (left.symtableentry.typ=typedconstsym) then
  679. begin
  680. tcsym:=ttypedconstsym(left.symtableentry);
  681. if tcsym.defintion^.typ=stringdef then
  682. begin
  683. end;
  684. end;
  685. {$endif}
  686. registersint:=left.registersint;
  687. { for ansi/wide strings, we need at least one register }
  688. if is_ansistring(left.resulttype.def) or
  689. is_widestring(left.resulttype.def) or
  690. { ... as well as for dynamic arrays }
  691. is_dynamic_array(left.resulttype.def) then
  692. registersint:=max(registersint,1);
  693. end
  694. else
  695. begin
  696. { this rules are suboptimal, but they should give }
  697. { good results }
  698. registersint:=max(left.registersint,right.registersint);
  699. { for ansi/wide strings, we need at least one register }
  700. if is_ansistring(left.resulttype.def) or
  701. is_widestring(left.resulttype.def) or
  702. { ... as well as for dynamic arrays }
  703. is_dynamic_array(left.resulttype.def) then
  704. registersint:=max(registersint,1);
  705. { need we an extra register when doing the restore ? }
  706. if (left.registersint<=right.registersint) and
  707. { only if the node needs less than 3 registers }
  708. { two for the right node and one for the }
  709. { left address }
  710. (registersint<3) then
  711. inc(registersint);
  712. { need we an extra register for the index ? }
  713. if (right.expectloc<>LOC_REGISTER)
  714. { only if the right node doesn't need a register }
  715. and (right.registersint<1) then
  716. inc(registersint);
  717. { not correct, but what works better ?
  718. if left.registersint>0 then
  719. registersint:=max(registersint,2)
  720. else
  721. min. one register
  722. registersint:=max(registersint,1);
  723. }
  724. end;
  725. registersfpu:=max(left.registersfpu,right.registersfpu);
  726. {$ifdef SUPPORT_MMX}
  727. registersmmx:=max(left.registersmmx,right.registersmmx);
  728. {$endif SUPPORT_MMX}
  729. if (not is_packed_array(left.resulttype.def)) or
  730. ((tarraydef(left.resulttype.def).elepackedbitsize mod 8) = 0) then
  731. if left.expectloc=LOC_CREFERENCE then
  732. expectloc:=LOC_CREFERENCE
  733. else
  734. expectloc:=LOC_REFERENCE
  735. else
  736. if left.expectloc=LOC_CREFERENCE then
  737. expectloc:=LOC_CSUBSETREF
  738. else
  739. expectloc:=LOC_SUBSETREF;
  740. end;
  741. {*****************************************************************************
  742. TWITHNODE
  743. *****************************************************************************}
  744. constructor twithnode.create(l:tnode);
  745. begin
  746. inherited create(withn,l);
  747. fileinfo:=l.fileinfo;
  748. end;
  749. destructor twithnode.destroy;
  750. begin
  751. inherited destroy;
  752. end;
  753. constructor twithnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  754. begin
  755. inherited ppuload(t,ppufile);
  756. end;
  757. procedure twithnode.ppuwrite(ppufile:tcompilerppufile);
  758. begin
  759. inherited ppuwrite(ppufile);
  760. end;
  761. function twithnode._getcopy : tnode;
  762. var
  763. p : twithnode;
  764. begin
  765. p:=twithnode(inherited _getcopy);
  766. result:=p;
  767. end;
  768. function twithnode.det_resulttype:tnode;
  769. begin
  770. result:=nil;
  771. resulttype:=voidtype;
  772. if assigned(left) then
  773. resulttypepass(left);
  774. end;
  775. function twithnode.pass_1 : tnode;
  776. begin
  777. result:=nil;
  778. expectloc:=LOC_VOID;
  779. registersint:=left.registersint;
  780. registersfpu:=left.registersfpu;
  781. {$ifdef SUPPORT_MMX}
  782. registersmmx:=left.registersmmx;
  783. {$endif SUPPORT_MMX}
  784. end;
  785. function twithnode.docompare(p: tnode): boolean;
  786. begin
  787. docompare :=
  788. inherited docompare(p);
  789. end;
  790. begin
  791. cloadvmtaddrnode := tloadvmtaddrnode;
  792. caddrnode := taddrnode;
  793. cderefnode := tderefnode;
  794. csubscriptnode := tsubscriptnode;
  795. cvecnode := tvecnode;
  796. cwithnode := twithnode;
  797. end.