nmem.pas 31 KB

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