nmem.pas 29 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927
  1. {
  2. $Id$
  3. Copyright (c) 2000 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 defines.inc}
  20. interface
  21. uses
  22. node,symtable,cpubase;
  23. type
  24. tloadvmtnode = class(tunarynode)
  25. constructor create(l : tnode);virtual;
  26. function pass_1 : tnode;override;
  27. end;
  28. thnewnode = class(tnode)
  29. constructor create;virtual;
  30. function pass_1 : tnode;override;
  31. end;
  32. tnewnode = class(tunarynode)
  33. constructor create(l : tnode);virtual;
  34. function pass_1 : tnode;override;
  35. end;
  36. thdisposenode = class(tunarynode)
  37. constructor create(l : tnode);virtual;
  38. function pass_1 : tnode;override;
  39. end;
  40. tsimplenewdisposenode = class(tunarynode)
  41. constructor create(n : tnodetype;l : tnode);
  42. function pass_1 : tnode;override;
  43. end;
  44. taddrnode = class(tunarynode)
  45. constructor create(l : tnode);virtual;
  46. function pass_1 : tnode;override;
  47. end;
  48. tdoubleaddrnode = class(tunarynode)
  49. constructor create(l : tnode);virtual;
  50. function pass_1 : tnode;override;
  51. end;
  52. tderefnode = class(tunarynode)
  53. constructor create(l : tnode);virtual;
  54. function pass_1 : tnode;override;
  55. end;
  56. tsubscriptnode = class(tunarynode)
  57. vs : pvarsym;
  58. constructor create(varsym : psym;l : tnode);virtual;
  59. function getcopy : tnode;override;
  60. function pass_1 : tnode;override;
  61. end;
  62. tvecnode = class(tbinarynode)
  63. constructor create(l,r : tnode);virtual;
  64. function pass_1 : tnode;override;
  65. end;
  66. tselfnode = class(tnode)
  67. constructor create(_class : pdef);virtual;
  68. function pass_1 : tnode;override;
  69. end;
  70. twithnode = class(tbinarynode)
  71. {$IFDEF NEWST}
  72. withsymtables : Pcollection;
  73. withreference : preference;
  74. {$ELSE}
  75. withsymtable : pwithsymtable;
  76. tablecount : longint;
  77. withreference:preference;
  78. {$ENDIF NEWST}
  79. constructor create(symtable : pwithsymtable;l,r : tnode;count : longint);virtual;
  80. destructor destroy;override;
  81. function getcopy : tnode;override;
  82. function pass_1 : tnode;override;
  83. end;
  84. function gensubscriptnode(varsym : pvarsym;l : tnode) : tsubscriptnode;
  85. function genselfnode(_class : pdef) : tselfnode;
  86. {$IFDEF NEWST}
  87. function genwithnode(symtables:Pcollection;l,r : tnode) : twithnode;
  88. {$ELSE}
  89. function genwithnode(symtable:pwithsymtable;l,r : tnode;count : longint) : twithnode;
  90. {$ENDIF NEWST}
  91. var
  92. cloadvmtnode : class of tloadvmtnode;
  93. chnewnode : class of thnewnode;
  94. cnewnode : class of tnewnode;
  95. chdisposenode : class of thdisposenode;
  96. csimplenewdisposenode : class of tsimplenewdisposenode;
  97. caddrnode : class of taddrnode;
  98. cdoubleaddrnode : class of tdoubleaddrnode;
  99. cderefnode : class of tderefnode;
  100. csubscriptnode : class of tsubscriptnode;
  101. cvecnode : class of tvecnode;
  102. cselfnode : class of tselfnode;
  103. cwithnode : class of twithnode;
  104. implementation
  105. uses
  106. globtype,systems,
  107. cutils,cobjects,verbose,globals,
  108. symconst,aasm,types,
  109. htypechk,pass_1,ncal,nld,ncon,ncnv
  110. {$ifdef newcg}
  111. ,cgbase
  112. {$else newcg}
  113. ,hcodegen
  114. {$endif newcg}
  115. ;
  116. function genselfnode(_class : pdef) : tselfnode;
  117. begin
  118. genselfnode:=cselfnode.create(_class);
  119. end;
  120. {$IFDEF NEWST}
  121. function genwithnode(symtables:Pcollection;l,r : tnode) : tnode;
  122. var
  123. p : tnode;
  124. begin
  125. !!!!!!!!! fixme
  126. p:=getnode;
  127. disposetyp:=dt_with;
  128. nodetype:=withn;
  129. left:=l;
  130. right:=r;
  131. registers32:=0;
  132. {$ifdef SUPPORT_MMX}
  133. registersmmx:=0;
  134. {$endif SUPPORT_MMX}
  135. resulttype:=nil;
  136. withsymtables:=symtables;
  137. withreference:=nil;
  138. set_file_line(l,p);
  139. genwithnode:=p;
  140. end;
  141. {$ELSE}
  142. function genwithnode(symtable : pwithsymtable;l,r : tnode;count : longint) : twithnode;
  143. begin
  144. genwithnode:=cwithnode.create(symtable,l,r,count);
  145. end;
  146. {$ENDIF NEWST}
  147. function gensubscriptnode(varsym : pvarsym;l : tnode) : tsubscriptnode;
  148. begin
  149. gensubscriptnode:=csubscriptnode.create(varsym,l);
  150. end;
  151. {*****************************************************************************
  152. TLOADVMTNODE
  153. *****************************************************************************}
  154. constructor tloadvmtnode.create(l : tnode);
  155. begin
  156. inherited create(loadvmtn,l);
  157. end;
  158. function tloadvmtnode.pass_1 : tnode;
  159. begin
  160. pass_1:=nil;
  161. registers32:=1;
  162. location.loc:=LOC_REGISTER;
  163. end;
  164. {*****************************************************************************
  165. THNEWNODE
  166. *****************************************************************************}
  167. constructor thnewnode.create;
  168. begin
  169. inherited create(hnewn);
  170. end;
  171. function thnewnode.pass_1 : tnode;
  172. begin
  173. pass_1:=nil;
  174. end;
  175. {*****************************************************************************
  176. TNEWNODE
  177. *****************************************************************************}
  178. constructor tnewnode.create(l : tnode);
  179. begin
  180. inherited create(newn,l);
  181. end;
  182. function tnewnode.pass_1 : tnode;
  183. begin
  184. pass_1:=nil;
  185. if assigned(left) then
  186. firstpass(left);
  187. if codegenerror then
  188. exit;
  189. if assigned(left) then
  190. begin
  191. registers32:=left.registers32;
  192. registersfpu:=left.registersfpu;
  193. {$ifdef SUPPORT_MMX}
  194. registersmmx:=left.registersmmx;
  195. {$endif SUPPORT_MMX}
  196. end;
  197. { result type is already set }
  198. procinfo^.flags:=procinfo^.flags or pi_do_call;
  199. if assigned(left) then
  200. location.loc:=LOC_REGISTER
  201. else
  202. location.loc:=LOC_REFERENCE;
  203. end;
  204. {*****************************************************************************
  205. THDISPOSENODE
  206. *****************************************************************************}
  207. constructor thdisposenode.create(l : tnode);
  208. begin
  209. inherited create(hdisposen,l);
  210. end;
  211. function thdisposenode.pass_1 : tnode;
  212. begin
  213. pass_1:=nil;
  214. firstpass(left);
  215. if codegenerror then
  216. exit;
  217. registers32:=left.registers32;
  218. registersfpu:=left.registersfpu;
  219. {$ifdef SUPPORT_MMX}
  220. registersmmx:=left.registersmmx;
  221. {$endif SUPPORT_MMX}
  222. if registers32<1 then
  223. registers32:=1;
  224. {
  225. if left.location.loc<>LOC_REFERENCE then
  226. CGMessage(cg_e_illegal_expression);
  227. }
  228. if left.location.loc=LOC_CREGISTER then
  229. inc(registers32);
  230. location.loc:=LOC_REFERENCE;
  231. resulttype:=ppointerdef(left.resulttype)^.pointertype.def;
  232. end;
  233. {*****************************************************************************
  234. TSIMPLENEWDISPOSENODE
  235. *****************************************************************************}
  236. constructor tsimplenewdisposenode.create(n : tnodetype;l : tnode);
  237. begin
  238. inherited create(n,l);
  239. end;
  240. function tsimplenewdisposenode.pass_1 : tnode;
  241. begin
  242. pass_1:=nil;
  243. { this cannot be in a register !! }
  244. make_not_regable(left);
  245. firstpass(left);
  246. if codegenerror then
  247. exit;
  248. { check the type }
  249. if left.resulttype=nil then
  250. left.resulttype:=generrordef;
  251. if (left.resulttype^.deftype<>pointerdef) then
  252. CGMessage1(type_e_pointer_type_expected,left.resulttype^.typename);
  253. if (left.location.loc<>LOC_REFERENCE) {and
  254. (left.location.loc<>LOC_CREGISTER)} then
  255. CGMessage(cg_e_illegal_expression);
  256. registers32:=left.registers32;
  257. registersfpu:=left.registersfpu;
  258. {$ifdef SUPPORT_MMX}
  259. registersmmx:=left.registersmmx;
  260. {$endif SUPPORT_MMX}
  261. resulttype:=voiddef;
  262. procinfo^.flags:=procinfo^.flags or pi_do_call;
  263. end;
  264. {*****************************************************************************
  265. TADDRNODE
  266. *****************************************************************************}
  267. constructor taddrnode.create(l : tnode);
  268. begin
  269. inherited create(addrn,l);
  270. end;
  271. function taddrnode.pass_1 : tnode;
  272. var
  273. hp : tnode;
  274. hp2 : pparaitem;
  275. hp3 : pabstractprocdef;
  276. begin
  277. pass_1:=nil;
  278. make_not_regable(left);
  279. if not(assigned(resulttype)) then
  280. begin
  281. { tp @procvar support (type of @procvar is a void pointer)
  282. Note: we need to leave the addrn in the tree,
  283. else we can't see the difference between @procvar and procvar.
  284. we set the procvarload flag so a secondpass does nothing for
  285. this node (PFV) }
  286. if (m_tp_procvar in aktmodeswitches) then
  287. begin
  288. hp:=left;
  289. case hp.nodetype of
  290. calln :
  291. begin
  292. { is it a procvar? }
  293. hp:=tcallnode(hp).right;
  294. if assigned(hp) then
  295. begin
  296. { remove calln node }
  297. tcallnode(left).right:=nil;
  298. left.free;
  299. left:=hp;
  300. firstpass(hp);
  301. include(flags,nf_procvarload);
  302. end;
  303. end;
  304. loadn,
  305. subscriptn,
  306. typeconvn,
  307. vecn,
  308. derefn :
  309. begin
  310. firstpass(hp);
  311. if codegenerror then
  312. exit;
  313. if hp.resulttype^.deftype=procvardef then
  314. include(flags,nf_procvarload);
  315. end;
  316. end;
  317. end;
  318. if nf_procvarload in flags then
  319. begin
  320. registers32:=left.registers32;
  321. registersfpu:=left.registersfpu;
  322. {$ifdef SUPPORT_MMX}
  323. registersmmx:=left.registersmmx;
  324. {$endif SUPPORT_MMX}
  325. if registers32<1 then
  326. registers32:=1;
  327. location.loc:=left.location.loc;
  328. resulttype:=voidpointerdef;
  329. exit;
  330. end;
  331. { proc 2 procvar ? }
  332. if left.nodetype=calln then
  333. begin
  334. { generate a methodcallnode or proccallnode }
  335. { we shouldn't convert things like @tcollection.load }
  336. if (tcallnode(left).symtableprocentry^.owner^.symtabletype=objectsymtable) and
  337. not(assigned(tcallnode(left).methodpointer) and (tcallnode(left).methodpointer.nodetype=typen)) then
  338. begin
  339. hp:=genloadmethodcallnode(pprocsym(tcallnode(left).symtableprocentry),tcallnode(left).symtableproc,
  340. tcallnode(left).methodpointer.getcopy);
  341. firstpass(hp);
  342. pass_1:=hp;
  343. exit;
  344. end
  345. else
  346. hp:=genloadcallnode(pprocsym(tcallnode(left).symtableprocentry),
  347. tcallnode(left).symtableproc);
  348. { result is a procedure variable }
  349. { No, to be TP compatible, you must return a pointer to
  350. the procedure that is stored in the procvar.}
  351. if not(m_tp_procvar in aktmodeswitches) then
  352. begin
  353. resulttype:=new(pprocvardef,init);
  354. { it could also be a procvar, not only pprocsym ! }
  355. if tcallnode(left).symtableprocentry^.typ=varsym then
  356. hp3:=pabstractprocdef(pvarsym(tcallnode(left).symtableprocentry)^.vartype.def)
  357. else
  358. hp3:=pabstractprocdef(pprocsym(tcallnode(left).symtableprocentry)^.definition);
  359. pprocvardef(resulttype)^.proctypeoption:=hp3^.proctypeoption;
  360. pprocvardef(resulttype)^.proccalloptions:=hp3^.proccalloptions;
  361. pprocvardef(resulttype)^.procoptions:=hp3^.procoptions;
  362. pprocvardef(resulttype)^.rettype:=hp3^.rettype;
  363. pprocvardef(resulttype)^.symtablelevel:=hp3^.symtablelevel;
  364. { method ? then set the methodpointer flag }
  365. if (hp3^.owner^.symtabletype=objectsymtable) and
  366. (pobjectdef(hp3^.owner^.defowner)^.is_class) then
  367. include(pprocvardef(resulttype)^.procoptions,po_methodpointer);
  368. { we need to process the parameters reverse so they are inserted
  369. in the correct right2left order (PFV) }
  370. hp2:=pparaitem(hp3^.para^.last);
  371. while assigned(hp2) do
  372. begin
  373. pprocvardef(resulttype)^.concatpara(hp2^.paratype,hp2^.paratyp,hp2^.defaultvalue);
  374. hp2:=pparaitem(hp2^.previous);
  375. end;
  376. end
  377. else
  378. resulttype:=voidpointerdef;
  379. left.free;
  380. left:=hp;
  381. end
  382. else
  383. begin
  384. firstpass(left);
  385. { what are we getting the address from an absolute sym? }
  386. hp:=left;
  387. while assigned(hp) and (hp.nodetype in [vecn,derefn,subscriptn]) do
  388. hp:=tunarynode(hp).left;
  389. if assigned(hp) and (hp.nodetype=loadn) and
  390. ((tloadnode(hp).symtableentry^.typ=absolutesym) and
  391. pabsolutesym(tloadnode(hp).symtableentry)^.absseg) then
  392. begin
  393. if not(cs_typed_addresses in aktlocalswitches) then
  394. resulttype:=voidfarpointerdef
  395. else
  396. resulttype:=new(ppointerdef,initfardef(left.resulttype));
  397. end
  398. else
  399. begin
  400. if not(cs_typed_addresses in aktlocalswitches) then
  401. resulttype:=voidpointerdef
  402. else
  403. resulttype:=new(ppointerdef,initdef(left.resulttype));
  404. end;
  405. end;
  406. end;
  407. firstpass(left);
  408. { this is like the function addr }
  409. inc(parsing_para_level);
  410. set_varstate(left,false);
  411. dec(parsing_para_level);
  412. if codegenerror then
  413. exit;
  414. { don't allow constants }
  415. if is_constnode(left) then
  416. begin
  417. aktfilepos:=left.fileinfo;
  418. CGMessage(type_e_no_addr_of_constant);
  419. end
  420. else
  421. begin
  422. { we should allow loc_mem for @string }
  423. if not(left.location.loc in [LOC_MEM,LOC_REFERENCE]) then
  424. begin
  425. aktfilepos:=left.fileinfo;
  426. CGMessage(cg_e_illegal_expression);
  427. end;
  428. end;
  429. registers32:=left.registers32;
  430. registersfpu:=left.registersfpu;
  431. {$ifdef SUPPORT_MMX}
  432. registersmmx:=left.registersmmx;
  433. {$endif SUPPORT_MMX}
  434. if registers32<1 then
  435. registers32:=1;
  436. { is this right for object of methods ?? }
  437. location.loc:=LOC_REGISTER;
  438. end;
  439. {*****************************************************************************
  440. TDOUBLEADDRNODE
  441. *****************************************************************************}
  442. constructor tdoubleaddrnode.create(l : tnode);
  443. begin
  444. inherited create(doubleaddrn,l);
  445. end;
  446. function tdoubleaddrnode.pass_1 : tnode;
  447. begin
  448. pass_1:=nil;
  449. make_not_regable(left);
  450. firstpass(left);
  451. inc(parsing_para_level);
  452. set_varstate(left,false);
  453. dec(parsing_para_level);
  454. if resulttype=nil then
  455. resulttype:=voidpointerdef;
  456. if codegenerror then
  457. exit;
  458. if (left.resulttype^.deftype)<>procvardef then
  459. CGMessage(cg_e_illegal_expression);
  460. if (left.location.loc<>LOC_REFERENCE) then
  461. CGMessage(cg_e_illegal_expression);
  462. registers32:=left.registers32;
  463. registersfpu:=left.registersfpu;
  464. {$ifdef SUPPORT_MMX}
  465. registersmmx:=left.registersmmx;
  466. {$endif SUPPORT_MMX}
  467. if registers32<1 then
  468. registers32:=1;
  469. location.loc:=LOC_REGISTER;
  470. end;
  471. {*****************************************************************************
  472. TDEREFNODE
  473. *****************************************************************************}
  474. constructor tderefnode.create(l : tnode);
  475. begin
  476. inherited create(derefn,l);
  477. end;
  478. function tderefnode.pass_1 : tnode;
  479. begin
  480. pass_1:=nil;
  481. firstpass(left);
  482. set_varstate(left,true);
  483. if codegenerror then
  484. begin
  485. resulttype:=generrordef;
  486. exit;
  487. end;
  488. registers32:=max(left.registers32,1);
  489. registersfpu:=left.registersfpu;
  490. {$ifdef SUPPORT_MMX}
  491. registersmmx:=left.registersmmx;
  492. {$endif SUPPORT_MMX}
  493. if left.resulttype^.deftype<>pointerdef then
  494. CGMessage(cg_e_invalid_qualifier);
  495. resulttype:=ppointerdef(left.resulttype)^.pointertype.def;
  496. location.loc:=LOC_REFERENCE;
  497. end;
  498. {*****************************************************************************
  499. TSUBSCRIPTNODE
  500. *****************************************************************************}
  501. constructor tsubscriptnode.create(varsym : psym;l : tnode);
  502. begin
  503. inherited create(subscriptn,l);
  504. { vs should be changed to psym! }
  505. vs:=pvarsym(varsym);
  506. end;
  507. function tsubscriptnode.getcopy : tnode;
  508. var
  509. p : tsubscriptnode;
  510. begin
  511. p:=tsubscriptnode(inherited getcopy);
  512. p.vs:=vs;
  513. getcopy:=p;
  514. end;
  515. function tsubscriptnode.pass_1 : tnode;
  516. begin
  517. pass_1:=nil;
  518. firstpass(left);
  519. if codegenerror then
  520. begin
  521. resulttype:=generrordef;
  522. exit;
  523. end;
  524. resulttype:=vs^.vartype.def;
  525. registers32:=left.registers32;
  526. registersfpu:=left.registersfpu;
  527. {$ifdef SUPPORT_MMX}
  528. registersmmx:=left.registersmmx;
  529. {$endif SUPPORT_MMX}
  530. { classes must be dereferenced implicit }
  531. if (left.resulttype^.deftype=objectdef) and
  532. pobjectdef(left.resulttype)^.is_class then
  533. begin
  534. if registers32=0 then
  535. registers32:=1;
  536. location.loc:=LOC_REFERENCE;
  537. end
  538. else
  539. begin
  540. if (left.location.loc<>LOC_MEM) and
  541. (left.location.loc<>LOC_REFERENCE) then
  542. CGMessage(cg_e_illegal_expression);
  543. set_location(location,left.location);
  544. end;
  545. end;
  546. {*****************************************************************************
  547. TVECNODE
  548. *****************************************************************************}
  549. constructor tvecnode.create(l,r : tnode);
  550. begin
  551. inherited create(vecn,l,r);
  552. end;
  553. function tvecnode.pass_1 : tnode;
  554. var
  555. harr : pdef;
  556. ct : tconverttype;
  557. {$ifdef consteval}
  558. tcsym : ptypedconstsym;
  559. {$endif}
  560. begin
  561. pass_1:=nil;
  562. firstpass(left);
  563. firstpass(right);
  564. if codegenerror then
  565. exit;
  566. { range check only for arrays }
  567. if (left.resulttype^.deftype=arraydef) then
  568. begin
  569. if (isconvertable(right.resulttype,parraydef(left.resulttype)^.rangetype.def,
  570. ct,ordconstn,false)=0) and
  571. not(is_equal(right.resulttype,parraydef(left.resulttype)^.rangetype.def)) then
  572. CGMessage(type_e_mismatch);
  573. end;
  574. { Never convert a boolean or a char !}
  575. { maybe type conversion }
  576. if (right.resulttype^.deftype<>enumdef) and
  577. not(is_char(right.resulttype)) and
  578. not(is_boolean(right.resulttype)) then
  579. begin
  580. right:=gentypeconvnode(right,s32bitdef);
  581. firstpass(right);
  582. if codegenerror then
  583. exit;
  584. end;
  585. { are we accessing a pointer[], then convert the pointer to
  586. an array first, in FPC this is allowed for all pointers in
  587. delphi/tp7 it's only allowed for pchars }
  588. if (left.resulttype^.deftype=pointerdef) and
  589. ((m_fpc in aktmodeswitches) or
  590. is_pchar(left.resulttype)) then
  591. begin
  592. { convert pointer to array }
  593. harr:=new(parraydef,init(0,$7fffffff,s32bitdef));
  594. parraydef(harr)^.elementtype.def:=ppointerdef(left.resulttype)^.pointertype.def;
  595. left:=gentypeconvnode(left,harr);
  596. firstpass(left);
  597. if codegenerror then
  598. exit;
  599. resulttype:=parraydef(harr)^.elementtype.def
  600. end;
  601. { determine return type }
  602. if not assigned(resulttype) then
  603. if left.resulttype^.deftype=arraydef then
  604. resulttype:=parraydef(left.resulttype)^.elementtype.def
  605. else if left.resulttype^.deftype=stringdef then
  606. begin
  607. { indexed access to strings }
  608. case pstringdef(left.resulttype)^.string_typ of
  609. {
  610. st_widestring : resulttype:=cwchardef;
  611. }
  612. st_ansistring : resulttype:=cchardef;
  613. st_longstring : resulttype:=cchardef;
  614. st_shortstring : resulttype:=cchardef;
  615. end;
  616. end
  617. else
  618. CGMessage(type_e_array_required);
  619. { the register calculation is easy if a const index is used }
  620. if right.nodetype=ordconstn then
  621. begin
  622. {$ifdef consteval}
  623. { constant evaluation }
  624. if (left.nodetype=loadn) and
  625. (left.symtableentry^.typ=typedconstsym) then
  626. begin
  627. tcsym:=ptypedconstsym(left.symtableentry);
  628. if tcsym^.defintion^.typ=stringdef then
  629. begin
  630. end;
  631. end;
  632. {$endif}
  633. registers32:=left.registers32;
  634. { for ansi/wide strings, we need at least one register }
  635. if is_ansistring(left.resulttype) or
  636. is_widestring(left.resulttype) then
  637. registers32:=max(registers32,1);
  638. end
  639. else
  640. begin
  641. { this rules are suboptimal, but they should give }
  642. { good results }
  643. registers32:=max(left.registers32,right.registers32);
  644. { for ansi/wide strings, we need at least one register }
  645. if is_ansistring(left.resulttype) or
  646. is_widestring(left.resulttype) then
  647. registers32:=max(registers32,1);
  648. { need we an extra register when doing the restore ? }
  649. if (left.registers32<=right.registers32) and
  650. { only if the node needs less than 3 registers }
  651. { two for the right node and one for the }
  652. { left address }
  653. (registers32<3) then
  654. inc(registers32);
  655. { need we an extra register for the index ? }
  656. if (right.location.loc<>LOC_REGISTER)
  657. { only if the right node doesn't need a register }
  658. and (right.registers32<1) then
  659. inc(registers32);
  660. { not correct, but what works better ?
  661. if left.registers32>0 then
  662. registers32:=max(registers32,2)
  663. else
  664. min. one register
  665. registers32:=max(registers32,1);
  666. }
  667. end;
  668. registersfpu:=max(left.registersfpu,right.registersfpu);
  669. {$ifdef SUPPORT_MMX}
  670. registersmmx:=max(left.registersmmx,right.registersmmx);
  671. {$endif SUPPORT_MMX}
  672. if left.location.loc in [LOC_CREGISTER,LOC_REFERENCE] then
  673. location.loc:=LOC_REFERENCE
  674. else
  675. location.loc:=LOC_MEM;
  676. end;
  677. {*****************************************************************************
  678. TSELFNODE
  679. *****************************************************************************}
  680. constructor tselfnode.create(_class : pdef);
  681. begin
  682. inherited create(selfn);
  683. resulttype:=_class;
  684. end;
  685. function tselfnode.pass_1 : tnode;
  686. begin
  687. pass_1:=nil;
  688. if (resulttype^.deftype=classrefdef) or
  689. ((resulttype^.deftype=objectdef)
  690. and pobjectdef(resulttype)^.is_class
  691. ) then
  692. location.loc:=LOC_CREGISTER
  693. else
  694. location.loc:=LOC_REFERENCE;
  695. end;
  696. {*****************************************************************************
  697. TWITHNODE
  698. *****************************************************************************}
  699. constructor twithnode.create(symtable : pwithsymtable;l,r : tnode;count : longint);
  700. begin
  701. inherited create(withn,l,r);
  702. withsymtable:=symtable;
  703. tablecount:=count;
  704. withreference:=nil;
  705. set_file_line(l);
  706. end;
  707. destructor twithnode.destroy;
  708. var
  709. symt : psymtable;
  710. i : longint;
  711. begin
  712. {$IFDEF NEWST}
  713. dispose(withsymtables,done);
  714. {$ELSE}
  715. symt:=withsymtable;
  716. for i:=1 to tablecount do
  717. begin
  718. if assigned(symt) then
  719. begin
  720. withsymtable:=pwithsymtable(symt^.next);
  721. dispose(symt,done);
  722. end;
  723. symt:=withsymtable;
  724. end;
  725. {$ENDIF NEWST}
  726. inherited destroy;
  727. end;
  728. function twithnode.getcopy : tnode;
  729. var
  730. p : twithnode;
  731. begin
  732. p:=twithnode(inherited getcopy);
  733. p.withsymtable:=withsymtable;
  734. p.tablecount:=tablecount;
  735. p.withreference:=withreference;
  736. result:=p;
  737. end;
  738. function twithnode.pass_1 : tnode;
  739. var
  740. symtable : pwithsymtable;
  741. i : longint;
  742. begin
  743. pass_1:=nil;
  744. if assigned(left) and assigned(right) then
  745. begin
  746. firstpass(left);
  747. unset_varstate(left);
  748. set_varstate(left,true);
  749. if codegenerror then
  750. exit;
  751. symtable:=withsymtable;
  752. for i:=1 to tablecount do
  753. begin
  754. if (left.nodetype=loadn) and
  755. (tloadnode(left).symtable=aktprocsym^.definition^.localst) then
  756. symtable^.direct_with:=true;
  757. symtable^.withnode:=self;
  758. symtable:=pwithsymtable(symtable^.next);
  759. end;
  760. firstpass(right);
  761. if codegenerror then
  762. exit;
  763. left_right_max;
  764. resulttype:=voiddef;
  765. end
  766. else
  767. begin
  768. { optimization }
  769. pass_1:=nil;
  770. end;
  771. end;
  772. end.
  773. {
  774. $Log$
  775. Revision 1.7 2000-10-14 21:52:55 peter
  776. * fixed memory leaks
  777. Revision 1.6 2000/10/14 10:14:51 peter
  778. * moehrendorf oct 2000 rewrite
  779. Revision 1.5 2000/10/01 19:48:24 peter
  780. * lot of compile updates for cg11
  781. Revision 1.4 2000/09/28 19:49:52 florian
  782. *** empty log message ***
  783. Revision 1.3 2000/09/25 15:37:14 florian
  784. * more fixes
  785. Revision 1.2 2000/09/25 15:05:25 florian
  786. * some updates
  787. Revision 1.1 2000/09/25 09:58:22 florian
  788. * first revision for testing purpose
  789. }