nmem.pas 37 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153
  1. {
  2. $Id$
  3. Copyright (c) 2000-2002 by Florian Klaempfl
  4. Type checking and register allocation for memory related nodes
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit nmem;
  19. {$i fpcdefs.inc}
  20. interface
  21. uses
  22. node,
  23. symtype,symppu,symdef,symsym,symtable,
  24. cpubase;
  25. type
  26. tloadvmtaddrnode = class(tunarynode)
  27. constructor create(l : tnode);virtual;
  28. function pass_1 : tnode;override;
  29. function det_resulttype:tnode;override;
  30. end;
  31. tloadvmtaddrnodeclass = class of tloadvmtaddrnode;
  32. tloadparentfpnode = class(tunarynode)
  33. parentpd : tprocdef;
  34. constructor create(pd:tprocdef);virtual;
  35. function pass_1 : tnode;override;
  36. function det_resulttype:tnode;override;
  37. function getcopy : tnode;override;
  38. end;
  39. tloadparentfpnodeclass = class of tloadparentfpnode;
  40. taddrnode = class(tunarynode)
  41. getprocvardef : tprocvardef;
  42. getprocvardefderef : tderef;
  43. constructor create(l : tnode);virtual;
  44. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  45. procedure ppuwrite(ppufile:tcompilerppufile);override;
  46. procedure mark_write;override;
  47. procedure buildderefimpl;override;
  48. procedure derefimpl;override;
  49. function getcopy : tnode;override;
  50. function pass_1 : tnode;override;
  51. function det_resulttype:tnode;override;
  52. end;
  53. taddrnodeclass = class of taddrnode;
  54. tderefnode = class(tunarynode)
  55. constructor create(l : tnode);virtual;
  56. function pass_1 : tnode;override;
  57. function det_resulttype:tnode;override;
  58. procedure mark_write;override;
  59. end;
  60. tderefnodeclass = class of tderefnode;
  61. tsubscriptnode = class(tunarynode)
  62. vs : tvarsym;
  63. vsderef : tderef;
  64. constructor create(varsym : tsym;l : tnode);virtual;
  65. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  66. procedure ppuwrite(ppufile:tcompilerppufile);override;
  67. procedure buildderefimpl;override;
  68. procedure derefimpl;override;
  69. function getcopy : tnode;override;
  70. function pass_1 : tnode;override;
  71. function docompare(p: tnode): boolean; override;
  72. function det_resulttype:tnode;override;
  73. procedure mark_write;override;
  74. end;
  75. tsubscriptnodeclass = class of tsubscriptnode;
  76. tvecnode = class(tbinarynode)
  77. constructor create(l,r : tnode);virtual;
  78. function pass_1 : tnode;override;
  79. function det_resulttype:tnode;override;
  80. procedure mark_write;override;
  81. end;
  82. tvecnodeclass = class of tvecnode;
  83. twithnode = class(tunarynode)
  84. withsymtable : twithsymtable;
  85. tablecount : longint;
  86. withrefnode : tnode;
  87. constructor create(l:tnode;symtable:twithsymtable;count:longint;r:tnode);
  88. destructor destroy;override;
  89. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  90. procedure ppuwrite(ppufile:tcompilerppufile);override;
  91. function getcopy : tnode;override;
  92. function pass_1 : tnode;override;
  93. function docompare(p: tnode): boolean; override;
  94. function det_resulttype:tnode;override;
  95. end;
  96. twithnodeclass = class of twithnode;
  97. var
  98. cloadvmtaddrnode : tloadvmtaddrnodeclass;
  99. cloadparentfpnode : tloadparentfpnodeclass;
  100. caddrnode : taddrnodeclass;
  101. cderefnode : tderefnodeclass;
  102. csubscriptnode : tsubscriptnodeclass;
  103. cvecnode : tvecnodeclass;
  104. cwithnode : twithnodeclass;
  105. implementation
  106. uses
  107. globtype,systems,
  108. cutils,verbose,globals,
  109. symconst,symbase,defutil,defcmp,
  110. nbas,
  111. htypechk,pass_1,ncal,nld,ncon,ncnv,cgbase,procinfo
  112. ;
  113. {*****************************************************************************
  114. TLOADVMTADDRNODE
  115. *****************************************************************************}
  116. constructor tloadvmtaddrnode.create(l : tnode);
  117. begin
  118. inherited create(loadvmtaddrn,l);
  119. end;
  120. function tloadvmtaddrnode.det_resulttype:tnode;
  121. begin
  122. result:=nil;
  123. resulttypepass(left);
  124. if codegenerror then
  125. exit;
  126. case left.resulttype.def.deftype of
  127. classrefdef :
  128. resulttype:=left.resulttype;
  129. objectdef :
  130. resulttype.setdef(tclassrefdef.create(left.resulttype));
  131. else
  132. Message(parser_e_pointer_to_class_expected);
  133. end;
  134. end;
  135. function tloadvmtaddrnode.pass_1 : tnode;
  136. begin
  137. result:=nil;
  138. expectloc:=LOC_REGISTER;
  139. if left.nodetype<>typen then
  140. begin
  141. firstpass(left);
  142. registers32:=left.registers32;
  143. end;
  144. if registers32<1 then
  145. registers32:=1;
  146. end;
  147. {*****************************************************************************
  148. TLOADPARENTFPNODE
  149. *****************************************************************************}
  150. constructor tloadparentfpnode.create(pd:tprocdef);
  151. begin
  152. inherited create(loadparentfpn,nil);
  153. if not assigned(pd) then
  154. internalerror(200309288);
  155. if (pd.parast.symtablelevel>current_procinfo.procdef.parast.symtablelevel) then
  156. internalerror(200309284);
  157. parentpd:=pd;
  158. end;
  159. function tloadparentfpnode.getcopy : tnode;
  160. var
  161. p : tloadparentfpnode;
  162. begin
  163. p:=tloadparentfpnode(inherited getcopy);
  164. p.parentpd:=parentpd;
  165. getcopy:=p;
  166. end;
  167. function tloadparentfpnode.det_resulttype:tnode;
  168. begin
  169. result:=nil;
  170. resulttype:=voidpointertype;
  171. end;
  172. function tloadparentfpnode.pass_1 : tnode;
  173. begin
  174. result:=nil;
  175. expectloc:=LOC_REGISTER;
  176. registers32:=1;
  177. end;
  178. {*****************************************************************************
  179. TADDRNODE
  180. *****************************************************************************}
  181. constructor taddrnode.create(l : tnode);
  182. begin
  183. inherited create(addrn,l);
  184. getprocvardef:=nil;
  185. end;
  186. constructor taddrnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  187. begin
  188. inherited ppuload(t,ppufile);
  189. ppufile.getderef(getprocvardefderef);
  190. end;
  191. procedure taddrnode.ppuwrite(ppufile:tcompilerppufile);
  192. begin
  193. inherited ppuwrite(ppufile);
  194. ppufile.putderef(getprocvardefderef);
  195. end;
  196. procedure Taddrnode.mark_write;
  197. begin
  198. {@procvar:=nil is legal in Delphi mode.}
  199. left.mark_write;
  200. end;
  201. procedure taddrnode.buildderefimpl;
  202. begin
  203. inherited buildderefimpl;
  204. getprocvardefderef.build(getprocvardef);
  205. end;
  206. procedure taddrnode.derefimpl;
  207. begin
  208. inherited derefimpl;
  209. getprocvardef:=tprocvardef(getprocvardefderef.resolve);
  210. end;
  211. function taddrnode.getcopy : tnode;
  212. var
  213. p : taddrnode;
  214. begin
  215. p:=taddrnode(inherited getcopy);
  216. p.getprocvardef:=getprocvardef;
  217. getcopy:=p;
  218. end;
  219. function taddrnode.det_resulttype:tnode;
  220. var
  221. hp : tnode;
  222. hp2 : TParaItem;
  223. hp3 : tabstractprocdef;
  224. begin
  225. result:=nil;
  226. resulttypepass(left);
  227. if codegenerror then
  228. exit;
  229. { don't allow constants }
  230. if is_constnode(left) then
  231. begin
  232. aktfilepos:=left.fileinfo;
  233. CGMessage(type_e_no_addr_of_constant);
  234. exit;
  235. end;
  236. { tp @procvar support (type of @procvar is a void pointer)
  237. Note: we need to leave the addrn in the tree,
  238. else we can't see the difference between @procvar and procvar.
  239. we set the procvarload flag so a secondpass does nothing for
  240. this node (PFV) }
  241. if (m_tp_procvar in aktmodeswitches) then
  242. begin
  243. case left.nodetype of
  244. calln :
  245. begin
  246. { a load of a procvar can't have parameters }
  247. if assigned(tcallnode(left).left) then
  248. CGMessage(cg_e_illegal_expression);
  249. { is it a procvar? }
  250. hp:=tcallnode(left).right;
  251. if assigned(hp) then
  252. begin
  253. { remove calln node }
  254. tcallnode(left).right:=nil;
  255. left.free;
  256. left:=hp;
  257. include(flags,nf_procvarload);
  258. end;
  259. end;
  260. loadn,
  261. subscriptn,
  262. typeconvn,
  263. vecn,
  264. derefn :
  265. begin
  266. if left.resulttype.def.deftype=procvardef then
  267. include(flags,nf_procvarload);
  268. end;
  269. end;
  270. if nf_procvarload in flags then
  271. begin
  272. resulttype:=voidpointertype;
  273. exit;
  274. end;
  275. end;
  276. { proc 2 procvar ? }
  277. if left.nodetype=calln then
  278. { if it were a valid construct, the addr node would already have }
  279. { been removed in the parser. This happens for (in FPC mode) }
  280. { procvar1 := @procvar2(parameters); }
  281. CGMessage(cg_e_illegal_expression)
  282. else
  283. if (left.nodetype=loadn) and (tloadnode(left).symtableentry.typ=procsym) then
  284. begin
  285. { the address is already available when loading a procedure of object }
  286. if assigned(tloadnode(left).left) then
  287. include(flags,nf_procvarload);
  288. { result is a procedure variable }
  289. { No, to be TP compatible, you must return a voidpointer to
  290. the procedure that is stored in the procvar.}
  291. if not(m_tp_procvar in aktmodeswitches) then
  292. begin
  293. if assigned(getprocvardef) and
  294. (tprocsym(tloadnode(left).symtableentry).procdef_count>1) then
  295. begin
  296. hp3:=tprocsym(tloadnode(left).symtableentry).search_procdef_byprocvardef(getprocvardef);
  297. if not assigned(hp3) then
  298. begin
  299. IncompatibleTypes(tprocsym(tloadnode(left).symtableentry).first_procdef,getprocvardef);
  300. exit;
  301. end;
  302. end
  303. else
  304. hp3:=tabstractprocdef(tprocsym(tloadnode(left).symtableentry).first_procdef);
  305. { create procvardef }
  306. resulttype.setdef(tprocvardef.create(hp3.parast.symtablelevel));
  307. tprocvardef(resulttype.def).proctypeoption:=hp3.proctypeoption;
  308. tprocvardef(resulttype.def).proccalloption:=hp3.proccalloption;
  309. tprocvardef(resulttype.def).procoptions:=hp3.procoptions;
  310. tprocvardef(resulttype.def).rettype:=hp3.rettype;
  311. { method ? then set the methodpointer flag }
  312. if (hp3.owner.symtabletype=objectsymtable) then
  313. include(tprocvardef(resulttype.def).procoptions,po_methodpointer);
  314. { only need the address of the method? this is needed
  315. for @tobject.create }
  316. if not assigned(tloadnode(left).left) then
  317. include(tprocvardef(resulttype.def).procoptions,po_addressonly);
  318. { Add parameters in left to right order }
  319. hp2:=TParaItem(hp3.Para.first);
  320. while assigned(hp2) do
  321. begin
  322. tprocvardef(resulttype.def).concatpara(nil,hp2.paratype,hp2.parasym,
  323. hp2.defaultvalue,hp2.is_hidden);
  324. hp2:=TParaItem(hp2.next);
  325. end;
  326. end
  327. else
  328. resulttype:=voidpointertype;
  329. end
  330. else
  331. begin
  332. { what are we getting the address from an absolute sym? }
  333. hp:=left;
  334. while assigned(hp) and (hp.nodetype in [vecn,derefn,subscriptn]) do
  335. hp:=tunarynode(hp).left;
  336. if assigned(hp) and (hp.nodetype=loadn) and
  337. ((tloadnode(hp).symtableentry.typ=absolutesym) and
  338. tabsolutesym(tloadnode(hp).symtableentry).absseg) then
  339. begin
  340. if not(cs_typed_addresses in aktlocalswitches) then
  341. resulttype:=voidfarpointertype
  342. else
  343. resulttype.setdef(tpointerdef.createfar(left.resulttype));
  344. end
  345. else
  346. begin
  347. if not(cs_typed_addresses in aktlocalswitches) then
  348. resulttype:=voidpointertype
  349. else
  350. resulttype.setdef(tpointerdef.create(left.resulttype));
  351. end;
  352. end;
  353. { this is like the function addr }
  354. inc(parsing_para_level);
  355. set_varstate(left,vs_used,false);
  356. dec(parsing_para_level);
  357. end;
  358. function taddrnode.pass_1 : tnode;
  359. begin
  360. result:=nil;
  361. firstpass(left);
  362. if codegenerror then
  363. exit;
  364. make_not_regable(left);
  365. if nf_procvarload in flags then
  366. begin
  367. registers32:=left.registers32;
  368. registersfpu:=left.registersfpu;
  369. {$ifdef SUPPORT_MMX}
  370. registersmmx:=left.registersmmx;
  371. {$endif SUPPORT_MMX}
  372. if registers32<1 then
  373. registers32:=1;
  374. expectloc:=left.expectloc;
  375. exit;
  376. end;
  377. { we should allow loc_mem for @string }
  378. if not(left.expectloc in [LOC_CREFERENCE,LOC_REFERENCE]) then
  379. begin
  380. aktfilepos:=left.fileinfo;
  381. CGMessage(cg_e_illegal_expression);
  382. end;
  383. registers32:=left.registers32;
  384. registersfpu:=left.registersfpu;
  385. {$ifdef SUPPORT_MMX}
  386. registersmmx:=left.registersmmx;
  387. {$endif SUPPORT_MMX}
  388. if registers32<1 then
  389. registers32:=1;
  390. { is this right for object of methods ?? }
  391. expectloc:=LOC_REGISTER;
  392. end;
  393. {*****************************************************************************
  394. TDEREFNODE
  395. *****************************************************************************}
  396. constructor tderefnode.create(l : tnode);
  397. begin
  398. inherited create(derefn,l);
  399. end;
  400. function tderefnode.det_resulttype:tnode;
  401. begin
  402. result:=nil;
  403. resulttypepass(left);
  404. set_varstate(left,vs_used,true);
  405. if codegenerror then
  406. exit;
  407. if left.resulttype.def.deftype=pointerdef then
  408. resulttype:=tpointerdef(left.resulttype.def).pointertype
  409. else
  410. CGMessage(cg_e_invalid_qualifier);
  411. end;
  412. procedure Tderefnode.mark_write;
  413. begin
  414. include(flags,nf_write);
  415. end;
  416. function tderefnode.pass_1 : tnode;
  417. begin
  418. result:=nil;
  419. firstpass(left);
  420. if codegenerror then
  421. exit;
  422. registers32:=max(left.registers32,1);
  423. registersfpu:=left.registersfpu;
  424. {$ifdef SUPPORT_MMX}
  425. registersmmx:=left.registersmmx;
  426. {$endif SUPPORT_MMX}
  427. expectloc:=LOC_REFERENCE;
  428. end;
  429. {*****************************************************************************
  430. TSUBSCRIPTNODE
  431. *****************************************************************************}
  432. constructor tsubscriptnode.create(varsym : tsym;l : tnode);
  433. begin
  434. inherited create(subscriptn,l);
  435. { vs should be changed to tsym! }
  436. vs:=tvarsym(varsym);
  437. end;
  438. constructor tsubscriptnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  439. begin
  440. inherited ppuload(t,ppufile);
  441. ppufile.getderef(vsderef);
  442. end;
  443. procedure tsubscriptnode.ppuwrite(ppufile:tcompilerppufile);
  444. begin
  445. inherited ppuwrite(ppufile);
  446. ppufile.putderef(vsderef);
  447. end;
  448. procedure tsubscriptnode.buildderefimpl;
  449. begin
  450. inherited buildderefimpl;
  451. vsderef.build(vs);
  452. end;
  453. procedure tsubscriptnode.derefimpl;
  454. begin
  455. inherited derefimpl;
  456. vs:=tvarsym(vsderef.resolve);
  457. end;
  458. function tsubscriptnode.getcopy : tnode;
  459. var
  460. p : tsubscriptnode;
  461. begin
  462. p:=tsubscriptnode(inherited getcopy);
  463. p.vs:=vs;
  464. getcopy:=p;
  465. end;
  466. function tsubscriptnode.det_resulttype:tnode;
  467. begin
  468. result:=nil;
  469. resulttypepass(left);
  470. resulttype:=vs.vartype;
  471. end;
  472. procedure Tsubscriptnode.mark_write;
  473. begin
  474. include(flags,nf_write);
  475. end;
  476. function tsubscriptnode.pass_1 : tnode;
  477. begin
  478. result:=nil;
  479. firstpass(left);
  480. if codegenerror then
  481. exit;
  482. registers32:=left.registers32;
  483. registersfpu:=left.registersfpu;
  484. {$ifdef SUPPORT_MMX}
  485. registersmmx:=left.registersmmx;
  486. {$endif SUPPORT_MMX}
  487. { classes must be dereferenced implicit }
  488. if is_class_or_interface(left.resulttype.def) then
  489. begin
  490. if registers32=0 then
  491. registers32:=1;
  492. expectloc:=LOC_REFERENCE;
  493. end
  494. else
  495. begin
  496. if (left.expectloc<>LOC_CREFERENCE) and
  497. (left.expectloc<>LOC_REFERENCE) then
  498. CGMessage(cg_e_illegal_expression);
  499. expectloc:=left.expectloc;
  500. end;
  501. end;
  502. function tsubscriptnode.docompare(p: tnode): boolean;
  503. begin
  504. docompare :=
  505. inherited docompare(p) and
  506. (vs = tsubscriptnode(p).vs);
  507. end;
  508. {*****************************************************************************
  509. TVECNODE
  510. *****************************************************************************}
  511. constructor tvecnode.create(l,r : tnode);
  512. begin
  513. inherited create(vecn,l,r);
  514. end;
  515. function tvecnode.det_resulttype:tnode;
  516. var
  517. htype : ttype;
  518. begin
  519. result:=nil;
  520. resulttypepass(left);
  521. resulttypepass(right);
  522. if codegenerror then
  523. exit;
  524. { maybe type conversion for the index value, but
  525. do not convert enums,booleans,char }
  526. if (right.resulttype.def.deftype<>enumdef) and
  527. not(is_char(right.resulttype.def)) and
  528. not(is_boolean(right.resulttype.def)) then
  529. begin
  530. inserttypeconv(right,s32bittype);
  531. end;
  532. case left.resulttype.def.deftype of
  533. arraydef :
  534. begin
  535. { check type of the index value }
  536. if (compare_defs(right.resulttype.def,tarraydef(left.resulttype.def).rangetype.def,right.nodetype)=te_incompatible) then
  537. CGMessage(type_e_mismatch);
  538. resulttype:=tarraydef(left.resulttype.def).elementtype;
  539. end;
  540. pointerdef :
  541. begin
  542. { are we accessing a pointer[], then convert the pointer to
  543. an array first, in FPC this is allowed for all pointers in
  544. delphi/tp7 it's only allowed for pchars }
  545. if (m_fpc in aktmodeswitches) or
  546. is_pchar(left.resulttype.def) or
  547. is_pwidechar(left.resulttype.def) then
  548. begin
  549. { convert pointer to array }
  550. htype.setdef(tarraydef.create(0,$7fffffff,s32bittype));
  551. tarraydef(htype.def).setelementtype(tpointerdef(left.resulttype.def).pointertype);
  552. inserttypeconv(left,htype);
  553. resulttype:=tarraydef(htype.def).elementtype;
  554. end
  555. else
  556. CGMessage(type_e_array_required);
  557. end;
  558. stringdef :
  559. begin
  560. { indexed access to 0 element is only allowed for shortstrings }
  561. if (right.nodetype=ordconstn) and
  562. (tordconstnode(right).value=0) and
  563. not(is_shortstring(left.resulttype.def)) then
  564. CGMessage(cg_e_can_access_element_zero);
  565. case tstringdef(left.resulttype.def).string_typ of
  566. st_widestring :
  567. resulttype:=cwidechartype;
  568. st_ansistring :
  569. resulttype:=cchartype;
  570. st_longstring :
  571. resulttype:=cchartype;
  572. st_shortstring :
  573. resulttype:=cchartype;
  574. end;
  575. end
  576. else
  577. CGMessage(type_e_array_required);
  578. end;
  579. end;
  580. procedure Tvecnode.mark_write;
  581. begin
  582. include(flags,nf_write);
  583. end;
  584. function tvecnode.pass_1 : tnode;
  585. {$ifdef consteval}
  586. var
  587. tcsym : ttypedconstsym;
  588. {$endif}
  589. begin
  590. result:=nil;
  591. firstpass(left);
  592. firstpass(right);
  593. if codegenerror then
  594. exit;
  595. if (nf_callunique in flags) and
  596. (is_ansistring(left.resulttype.def) or
  597. is_widestring(left.resulttype.def)) then
  598. begin
  599. left := ctypeconvnode.create_explicit(ccallnode.createintern('fpc_'+tstringdef(left.resulttype.def).stringtypname+'_unique',
  600. ccallparanode.create(
  601. ctypeconvnode.create_explicit(left,voidpointertype),nil)),
  602. left.resulttype);
  603. firstpass(left);
  604. { double resulttype passes somwhere else may cause this to be }
  605. { reset though :/ }
  606. exclude(flags,nf_callunique);
  607. end;
  608. { the register calculation is easy if a const index is used }
  609. if right.nodetype=ordconstn then
  610. begin
  611. {$ifdef consteval}
  612. { constant evaluation }
  613. if (left.nodetype=loadn) and
  614. (left.symtableentry.typ=typedconstsym) then
  615. begin
  616. tcsym:=ttypedconstsym(left.symtableentry);
  617. if tcsym.defintion^.typ=stringdef then
  618. begin
  619. end;
  620. end;
  621. {$endif}
  622. registers32:=left.registers32;
  623. { for ansi/wide strings, we need at least one register }
  624. if is_ansistring(left.resulttype.def) or
  625. is_widestring(left.resulttype.def) or
  626. { ... as well as for dynamic arrays }
  627. is_dynamic_array(left.resulttype.def) then
  628. registers32:=max(registers32,1);
  629. end
  630. else
  631. begin
  632. { this rules are suboptimal, but they should give }
  633. { good results }
  634. registers32:=max(left.registers32,right.registers32);
  635. { for ansi/wide strings, we need at least one register }
  636. if is_ansistring(left.resulttype.def) or
  637. is_widestring(left.resulttype.def) or
  638. { ... as well as for dynamic arrays }
  639. is_dynamic_array(left.resulttype.def) then
  640. registers32:=max(registers32,1);
  641. { need we an extra register when doing the restore ? }
  642. if (left.registers32<=right.registers32) and
  643. { only if the node needs less than 3 registers }
  644. { two for the right node and one for the }
  645. { left address }
  646. (registers32<3) then
  647. inc(registers32);
  648. { need we an extra register for the index ? }
  649. if (right.expectloc<>LOC_REGISTER)
  650. { only if the right node doesn't need a register }
  651. and (right.registers32<1) then
  652. inc(registers32);
  653. { not correct, but what works better ?
  654. if left.registers32>0 then
  655. registers32:=max(registers32,2)
  656. else
  657. min. one register
  658. registers32:=max(registers32,1);
  659. }
  660. end;
  661. registersfpu:=max(left.registersfpu,right.registersfpu);
  662. {$ifdef SUPPORT_MMX}
  663. registersmmx:=max(left.registersmmx,right.registersmmx);
  664. {$endif SUPPORT_MMX}
  665. if left.expectloc=LOC_CREFERENCE then
  666. expectloc:=LOC_CREFERENCE
  667. else
  668. expectloc:=LOC_REFERENCE;
  669. end;
  670. {*****************************************************************************
  671. TWITHNODE
  672. *****************************************************************************}
  673. constructor twithnode.create(l:tnode;symtable:twithsymtable;count:longint;r:tnode);
  674. begin
  675. inherited create(withn,l);
  676. withrefnode:=r;
  677. withsymtable:=symtable;
  678. tablecount:=count;
  679. set_file_line(l);
  680. end;
  681. destructor twithnode.destroy;
  682. var
  683. hsymt,
  684. symt : tsymtable;
  685. i : longint;
  686. begin
  687. symt:=withsymtable;
  688. for i:=1 to tablecount do
  689. begin
  690. if assigned(symt) then
  691. begin
  692. hsymt:=symt.next;
  693. symt.free;
  694. symt:=hsymt;
  695. end;
  696. end;
  697. inherited destroy;
  698. end;
  699. constructor twithnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  700. begin
  701. inherited ppuload(t,ppufile);
  702. internalerror(200208192);
  703. end;
  704. procedure twithnode.ppuwrite(ppufile:tcompilerppufile);
  705. begin
  706. inherited ppuwrite(ppufile);
  707. internalerror(200208193);
  708. end;
  709. function twithnode.getcopy : tnode;
  710. var
  711. p : twithnode;
  712. begin
  713. p:=twithnode(inherited getcopy);
  714. p.withsymtable:=withsymtable;
  715. p.tablecount:=tablecount;
  716. if assigned(p.withrefnode) then
  717. p.withrefnode:=withrefnode.getcopy
  718. else
  719. p.withrefnode:=nil;
  720. result:=p;
  721. end;
  722. function twithnode.det_resulttype:tnode;
  723. begin
  724. result:=nil;
  725. resulttype:=voidtype;
  726. resulttypepass(withrefnode);
  727. //unset_varstate(withrefnode);
  728. set_varstate(withrefnode,vs_used,true);
  729. if codegenerror then
  730. exit;
  731. if (withrefnode.nodetype=vecn) and
  732. (nf_memseg in withrefnode.flags) then
  733. CGMessage(parser_e_no_with_for_variable_in_other_segments);
  734. if assigned(left) then
  735. resulttypepass(left);
  736. end;
  737. function twithnode.pass_1 : tnode;
  738. begin
  739. result:=nil;
  740. expectloc:=LOC_VOID;
  741. if assigned(left) then
  742. begin
  743. firstpass(left);
  744. registers32:=left.registers32;
  745. registersfpu:=left.registersfpu;
  746. {$ifdef SUPPORT_MMX}
  747. registersmmx:=left.registersmmx;
  748. {$endif SUPPORT_MMX}
  749. end;
  750. if assigned(withrefnode) then
  751. begin
  752. firstpass(withrefnode);
  753. if withrefnode.registers32 > registers32 then
  754. registers32:=withrefnode.registers32;
  755. if withrefnode.registersfpu > registersfpu then
  756. registers32:=withrefnode.registersfpu;
  757. {$ifdef SUPPORT_MMX}
  758. if withrefnode.registersmmx > registersmmx then
  759. registersmmx:=withrefnode.registersmmx;
  760. {$endif SUPPORT_MMX}
  761. end;
  762. end;
  763. function twithnode.docompare(p: tnode): boolean;
  764. begin
  765. docompare :=
  766. inherited docompare(p) and
  767. (withsymtable = twithnode(p).withsymtable) and
  768. (tablecount = twithnode(p).tablecount) and
  769. (withrefnode.isequal(twithnode(p).withrefnode));
  770. end;
  771. begin
  772. cloadvmtaddrnode := tloadvmtaddrnode;
  773. caddrnode := taddrnode;
  774. cderefnode := tderefnode;
  775. csubscriptnode := tsubscriptnode;
  776. cvecnode := tvecnode;
  777. cwithnode := twithnode;
  778. end.
  779. {
  780. $Log$
  781. Revision 1.70 2003-10-31 18:44:18 peter
  782. * don't search for compatible procvars when the proc is not
  783. overloaded
  784. Revision 1.69 2003/10/31 15:52:58 peter
  785. * support creating classes using <class of tobject>.create
  786. Revision 1.68 2003/10/23 14:44:07 peter
  787. * splitted buildderef and buildderefimpl to fix interface crc
  788. calculation
  789. Revision 1.67 2003/10/22 20:40:00 peter
  790. * write derefdata in a separate ppu entry
  791. Revision 1.66 2003/10/21 18:16:13 peter
  792. * IncompatibleTypes() added that will include unit names when
  793. the typenames are the same
  794. Revision 1.65 2003/10/08 19:19:45 peter
  795. * set_varstate cleanup
  796. Revision 1.64 2003/10/01 20:34:49 peter
  797. * procinfo unit contains tprocinfo
  798. * cginfo renamed to cgbase
  799. * moved cgmessage to verbose
  800. * fixed ppc and sparc compiles
  801. Revision 1.63 2003/09/28 17:55:04 peter
  802. * parent framepointer changed to hidden parameter
  803. * tloadparentfpnode added
  804. Revision 1.62 2003/09/06 22:27:08 florian
  805. * fixed web bug 2669
  806. * cosmetic fix in printnode
  807. * tobjectdef.gettypename implemented
  808. Revision 1.61 2003/09/03 11:18:37 florian
  809. * fixed arm concatcopy
  810. + arm support in the common compiler sources added
  811. * moved some generic cg code around
  812. + tfputype added
  813. * ...
  814. Revision 1.60 2003/08/10 17:25:23 peter
  815. * fixed some reported bugs
  816. Revision 1.59 2003/06/17 19:24:08 jonas
  817. * fixed conversion of fpc_*str_unique to compilerproc
  818. Revision 1.58 2003/06/17 16:34:44 jonas
  819. * lots of newra fixes (need getfuncretparaloc implementation for i386)!
  820. * renamed all_intregisters to volatile_intregisters and made it
  821. processor dependent
  822. Revision 1.57 2003/06/07 20:26:32 peter
  823. * re-resolving added instead of reloading from ppu
  824. * tderef object added to store deref info for resolving
  825. Revision 1.56 2003/06/07 18:57:04 jonas
  826. + added freeintparaloc
  827. * ppc get/freeintparaloc now check whether the parameter regs are
  828. properly allocated/deallocated (and get an extra list para)
  829. * ppc a_call_* now internalerrors if pi_do_call is not yet set
  830. * fixed lot of missing pi_do_call's
  831. Revision 1.55 2003/05/24 17:15:24 jonas
  832. * added missing firstpass for withrefnode
  833. Revision 1.54 2003/05/11 14:45:12 peter
  834. * tloadnode does not support objectsymtable,withsymtable anymore
  835. * withnode cleanup
  836. * direct with rewritten to use temprefnode
  837. Revision 1.53 2003/05/09 17:47:02 peter
  838. * self moved to hidden parameter
  839. * removed hdisposen,hnewn,selfn
  840. Revision 1.52 2003/05/05 14:53:16 peter
  841. * vs_hidden replaced by is_hidden boolean
  842. Revision 1.51 2003/04/27 11:21:33 peter
  843. * aktprocdef renamed to current_procdef
  844. * procinfo renamed to current_procinfo
  845. * procinfo will now be stored in current_module so it can be
  846. cleaned up properly
  847. * gen_main_procsym changed to create_main_proc and release_main_proc
  848. to also generate a tprocinfo structure
  849. * fixed unit implicit initfinal
  850. Revision 1.50 2003/04/27 07:29:50 peter
  851. * current_procdef cleanup, current_procdef is now always nil when parsing
  852. a new procdef declaration
  853. * aktprocsym removed
  854. * lexlevel removed, use symtable.symtablelevel instead
  855. * implicit init/final code uses the normal genentry/genexit
  856. * funcret state checking updated for new funcret handling
  857. Revision 1.49 2003/04/23 10:10:54 peter
  858. * procvar is not compared in addrn
  859. Revision 1.48 2003/04/22 23:50:23 peter
  860. * firstpass uses expectloc
  861. * checks if there are differences between the expectloc and
  862. location.loc from secondpass in EXTDEBUG
  863. Revision 1.47 2003/04/10 17:57:52 peter
  864. * vs_hidden released
  865. Revision 1.46 2003/01/30 21:46:57 peter
  866. * self fixes for static methods (merged)
  867. Revision 1.45 2003/01/09 21:52:37 peter
  868. * merged some verbosity options.
  869. * V_LineInfo is a verbosity flag to include line info
  870. Revision 1.44 2003/01/06 21:16:52 peter
  871. * po_addressonly added to retrieve the address of a methodpointer
  872. only, this is used for @tclass.method which has no self pointer
  873. Revision 1.43 2003/01/04 15:54:03 daniel
  874. * Fixed mark_write for @ operator
  875. (can happen when compiling @procvar:=nil (Delphi mode construction))
  876. Revision 1.42 2003/01/03 12:15:56 daniel
  877. * Removed ifdefs around notifications
  878. ifdefs around for loop optimizations remain
  879. Revision 1.41 2002/11/25 17:43:20 peter
  880. * splitted defbase in defutil,symutil,defcmp
  881. * merged isconvertable and is_equal into compare_defs(_ext)
  882. * made operator search faster by walking the list only once
  883. Revision 1.40 2002/09/27 21:13:28 carl
  884. * low-highval always checked if limit ober 2GB is reached (to avoid overflow)
  885. Revision 1.39 2002/09/01 18:44:17 peter
  886. * cleanup of tvecnode.det_resulttype
  887. * move 0 element of string access check to resulttype
  888. Revision 1.38 2002/09/01 13:28:38 daniel
  889. - write_access fields removed in favor of a flag
  890. Revision 1.37 2002/09/01 08:01:16 daniel
  891. * Removed sets from Tcallnode.det_resulttype
  892. + Added read/write notifications of variables. These will be usefull
  893. for providing information for several optimizations. For example
  894. the value of the loop variable of a for loop does matter is the
  895. variable is read after the for loop, but if it's no longer used
  896. or written, it doesn't matter and this can be used to optimize
  897. the loop code generation.
  898. Revision 1.36 2002/08/19 19:36:43 peter
  899. * More fixes for cross unit inlining, all tnodes are now implemented
  900. * Moved pocall_internconst to po_internconst because it is not a
  901. calling type at all and it conflicted when inlining of these small
  902. functions was requested
  903. Revision 1.35 2002/07/23 09:51:23 daniel
  904. * Tried to make Tprocsym.defs protected. I didn't succeed but the cleanups
  905. are worth comitting.
  906. Revision 1.34 2002/07/20 11:57:54 florian
  907. * types.pas renamed to defbase.pas because D6 contains a types
  908. unit so this would conflicts if D6 programms are compiled
  909. + Willamette/SSE2 instructions to assembler added
  910. Revision 1.33 2002/05/18 13:34:10 peter
  911. * readded missing revisions
  912. Revision 1.32 2002/05/16 19:46:39 carl
  913. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  914. + try to fix temp allocation (still in ifdef)
  915. + generic constructor calls
  916. + start of tassembler / tmodulebase class cleanup
  917. Revision 1.30 2002/05/12 16:53:07 peter
  918. * moved entry and exitcode to ncgutil and cgobj
  919. * foreach gets extra argument for passing local data to the
  920. iterator function
  921. * -CR checks also class typecasts at runtime by changing them
  922. into as
  923. * fixed compiler to cycle with the -CR option
  924. * fixed stabs with elf writer, finally the global variables can
  925. be watched
  926. * removed a lot of routines from cga unit and replaced them by
  927. calls to cgobj
  928. * u32bit-s32bit updates for and,or,xor nodes. When one element is
  929. u32bit then the other is typecasted also to u32bit without giving
  930. a rangecheck warning/error.
  931. * fixed pascal calling method with reversing also the high tree in
  932. the parast, detected by tcalcst3 test
  933. Revision 1.29 2002/04/21 19:02:04 peter
  934. * removed newn and disposen nodes, the code is now directly
  935. inlined from pexpr
  936. * -an option that will write the secondpass nodes to the .s file, this
  937. requires EXTDEBUG define to actually write the info
  938. * fixed various internal errors and crashes due recent code changes
  939. Revision 1.28 2002/04/20 21:32:23 carl
  940. + generic FPC_CHECKPOINTER
  941. + first parameter offset in stack now portable
  942. * rename some constants
  943. + move some cpu stuff to other units
  944. - remove unused constents
  945. * fix stacksize for some targets
  946. * fix generic size problems which depend now on EXTEND_SIZE constant
  947. Revision 1.27 2002/04/02 17:11:29 peter
  948. * tlocation,treference update
  949. * LOC_CONSTANT added for better constant handling
  950. * secondadd splitted in multiple routines
  951. * location_force_reg added for loading a location to a register
  952. of a specified size
  953. * secondassignment parses now first the right and then the left node
  954. (this is compatible with Kylix). This saves a lot of push/pop especially
  955. with string operations
  956. * adapted some routines to use the new cg methods
  957. Revision 1.26 2002/04/01 20:57:13 jonas
  958. * fixed web bug 1907
  959. * fixed some other procvar related bugs (all related to accepting procvar
  960. constructs with either too many or too little parameters)
  961. (both merged, includes second typo fix of pexpr.pas)
  962. }