nmem.pas 31 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041
  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. set_varstate(left,false);
  515. resulttype:=vs.vartype;
  516. end;
  517. function tsubscriptnode.pass_1 : tnode;
  518. begin
  519. result:=nil;
  520. firstpass(left);
  521. if codegenerror then
  522. exit;
  523. registers32:=left.registers32;
  524. registersfpu:=left.registersfpu;
  525. {$ifdef SUPPORT_MMX}
  526. registersmmx:=left.registersmmx;
  527. {$endif SUPPORT_MMX}
  528. { classes must be dereferenced implicit }
  529. if is_class_or_interface(left.resulttype.def) then
  530. begin
  531. if registers32=0 then
  532. registers32:=1;
  533. location.loc:=LOC_REFERENCE;
  534. end
  535. else
  536. begin
  537. if (left.location.loc<>LOC_MEM) and
  538. (left.location.loc<>LOC_REFERENCE) then
  539. CGMessage(cg_e_illegal_expression);
  540. set_location(location,left.location);
  541. end;
  542. end;
  543. function tsubscriptnode.docompare(p: tnode): boolean;
  544. begin
  545. docompare :=
  546. inherited docompare(p) and
  547. (vs = tsubscriptnode(p).vs);
  548. end;
  549. {*****************************************************************************
  550. TVECNODE
  551. *****************************************************************************}
  552. constructor tvecnode.create(l,r : tnode);
  553. begin
  554. inherited create(vecn,l,r);
  555. end;
  556. function tvecnode.det_resulttype:tnode;
  557. var
  558. htype : ttype;
  559. ct : tconverttype;
  560. begin
  561. result:=nil;
  562. resulttypepass(left);
  563. resulttypepass(right);
  564. if codegenerror then
  565. exit;
  566. { range check only for arrays }
  567. if (left.resulttype.def.deftype=arraydef) then
  568. begin
  569. if (isconvertable(right.resulttype.def,tarraydef(left.resulttype.def).rangetype.def,
  570. ct,ordconstn,false)=0) and
  571. not(is_equal(right.resulttype.def,tarraydef(left.resulttype.def).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.def.deftype<>enumdef) and
  577. not(is_char(right.resulttype.def)) and
  578. not(is_boolean(right.resulttype.def)) then
  579. begin
  580. inserttypeconv(right,s32bittype);
  581. end;
  582. { are we accessing a pointer[], then convert the pointer to
  583. an array first, in FPC this is allowed for all pointers in
  584. delphi/tp7 it's only allowed for pchars }
  585. if (left.resulttype.def.deftype=pointerdef) and
  586. ((m_fpc in aktmodeswitches) or
  587. is_pchar(left.resulttype.def) or
  588. is_pwidechar(left.resulttype.def)) then
  589. begin
  590. { convert pointer to array }
  591. htype.setdef(tarraydef.create(0,$7fffffff,s32bittype));
  592. tarraydef(htype.def).elementtype:=tpointerdef(left.resulttype.def).pointertype;
  593. inserttypeconv(left,htype);
  594. resulttype:=tarraydef(htype.def).elementtype;
  595. end;
  596. { determine return type }
  597. if not assigned(resulttype.def) then
  598. if left.resulttype.def.deftype=arraydef then
  599. resulttype:=tarraydef(left.resulttype.def).elementtype
  600. else if left.resulttype.def.deftype=stringdef then
  601. begin
  602. { indexed access to strings }
  603. case tstringdef(left.resulttype.def).string_typ of
  604. st_widestring :
  605. resulttype:=cwidechartype;
  606. st_ansistring :
  607. resulttype:=cchartype;
  608. st_longstring :
  609. resulttype:=cchartype;
  610. st_shortstring :
  611. resulttype:=cchartype;
  612. end;
  613. end
  614. else
  615. CGMessage(type_e_array_required);
  616. end;
  617. function tvecnode.pass_1 : tnode;
  618. {$ifdef consteval}
  619. var
  620. tcsym : ttypedconstsym;
  621. {$endif}
  622. begin
  623. result:=nil;
  624. firstpass(left);
  625. firstpass(right);
  626. if codegenerror then
  627. exit;
  628. { the register calculation is easy if a const index is used }
  629. if right.nodetype=ordconstn then
  630. begin
  631. {$ifdef consteval}
  632. { constant evaluation }
  633. if (left.nodetype=loadn) and
  634. (left.symtableentry.typ=typedconstsym) then
  635. begin
  636. tcsym:=ttypedconstsym(left.symtableentry);
  637. if tcsym.defintion^.typ=stringdef then
  638. begin
  639. end;
  640. end;
  641. {$endif}
  642. registers32:=left.registers32;
  643. { for ansi/wide strings, we need at least one register }
  644. if is_ansistring(left.resulttype.def) or
  645. is_widestring(left.resulttype.def) or
  646. { ... as well as for dynamic arrays }
  647. is_dynamic_array(left.resulttype.def) then
  648. registers32:=max(registers32,1);
  649. end
  650. else
  651. begin
  652. { this rules are suboptimal, but they should give }
  653. { good results }
  654. registers32:=max(left.registers32,right.registers32);
  655. { for ansi/wide strings, we need at least one register }
  656. if is_ansistring(left.resulttype.def) or
  657. is_widestring(left.resulttype.def) or
  658. { ... as well as for dynamic arrays }
  659. is_dynamic_array(left.resulttype.def) then
  660. registers32:=max(registers32,1);
  661. { need we an extra register when doing the restore ? }
  662. if (left.registers32<=right.registers32) and
  663. { only if the node needs less than 3 registers }
  664. { two for the right node and one for the }
  665. { left address }
  666. (registers32<3) then
  667. inc(registers32);
  668. { need we an extra register for the index ? }
  669. if (right.location.loc<>LOC_REGISTER)
  670. { only if the right node doesn't need a register }
  671. and (right.registers32<1) then
  672. inc(registers32);
  673. { not correct, but what works better ?
  674. if left.registers32>0 then
  675. registers32:=max(registers32,2)
  676. else
  677. min. one register
  678. registers32:=max(registers32,1);
  679. }
  680. end;
  681. registersfpu:=max(left.registersfpu,right.registersfpu);
  682. {$ifdef SUPPORT_MMX}
  683. registersmmx:=max(left.registersmmx,right.registersmmx);
  684. {$endif SUPPORT_MMX}
  685. if left.location.loc in [LOC_CREGISTER,LOC_REFERENCE] then
  686. location.loc:=LOC_REFERENCE
  687. else
  688. location.loc:=LOC_MEM;
  689. end;
  690. {*****************************************************************************
  691. TSELFNODE
  692. *****************************************************************************}
  693. constructor tselfnode.create(_class : tobjectdef);
  694. begin
  695. inherited create(selfn);
  696. classdef:=_class;
  697. end;
  698. function tselfnode.det_resulttype:tnode;
  699. begin
  700. result:=nil;
  701. resulttype.setdef(classdef);
  702. end;
  703. function tselfnode.pass_1 : tnode;
  704. begin
  705. result:=nil;
  706. if (resulttype.def.deftype=classrefdef) or
  707. is_class(resulttype.def) then
  708. location.loc:=LOC_CREGISTER
  709. else
  710. location.loc:=LOC_REFERENCE;
  711. end;
  712. {*****************************************************************************
  713. TWITHNODE
  714. *****************************************************************************}
  715. constructor twithnode.create(symtable : twithsymtable;l,r : tnode;count : longint);
  716. begin
  717. inherited create(withn,l,r);
  718. withsymtable:=symtable;
  719. tablecount:=count;
  720. withreference:=nil;
  721. set_file_line(l);
  722. end;
  723. destructor twithnode.destroy;
  724. var
  725. symt : tsymtable;
  726. i : longint;
  727. begin
  728. symt:=withsymtable;
  729. for i:=1 to tablecount do
  730. begin
  731. if assigned(symt) then
  732. begin
  733. withsymtable:=twithsymtable(symt.next);
  734. symt.free;
  735. end;
  736. symt:=withsymtable;
  737. end;
  738. inherited destroy;
  739. end;
  740. function twithnode.getcopy : tnode;
  741. var
  742. p : twithnode;
  743. begin
  744. p:=twithnode(inherited getcopy);
  745. p.withsymtable:=withsymtable;
  746. p.tablecount:=tablecount;
  747. p.withreference:=withreference;
  748. result:=p;
  749. end;
  750. function twithnode.det_resulttype:tnode;
  751. var
  752. symtable : twithsymtable;
  753. i : longint;
  754. begin
  755. result:=nil;
  756. resulttype:=voidtype;
  757. if assigned(left) and assigned(right) then
  758. begin
  759. resulttypepass(left);
  760. unset_varstate(left);
  761. set_varstate(left,true);
  762. if codegenerror then
  763. exit;
  764. symtable:=withsymtable;
  765. for i:=1 to tablecount do
  766. begin
  767. if (left.nodetype=loadn) and
  768. (tloadnode(left).symtable=aktprocsym.definition.localst) then
  769. symtable.direct_with:=true;
  770. symtable.withnode:=self;
  771. symtable:=twithsymtable(symtable.next);
  772. end;
  773. resulttypepass(right);
  774. if codegenerror then
  775. exit;
  776. end;
  777. resulttype:=voidtype;
  778. end;
  779. function twithnode.pass_1 : tnode;
  780. begin
  781. result:=nil;
  782. if assigned(left) and assigned(right) then
  783. begin
  784. firstpass(left);
  785. firstpass(right);
  786. if codegenerror then
  787. exit;
  788. left_right_max;
  789. end
  790. else
  791. begin
  792. { optimization }
  793. result:=nil;
  794. end;
  795. end;
  796. function twithnode.docompare(p: tnode): boolean;
  797. begin
  798. docompare :=
  799. inherited docompare(p) and
  800. (withsymtable = twithnode(p).withsymtable) and
  801. (tablecount = twithnode(p).tablecount);
  802. end;
  803. begin
  804. cloadvmtnode := tloadvmtnode;
  805. chnewnode := thnewnode;
  806. cnewnode := tnewnode;
  807. chdisposenode := thdisposenode;
  808. csimplenewdisposenode := tsimplenewdisposenode;
  809. caddrnode := taddrnode;
  810. cdoubleaddrnode := tdoubleaddrnode;
  811. cderefnode := tderefnode;
  812. csubscriptnode := tsubscriptnode;
  813. cvecnode := tvecnode;
  814. cselfnode := tselfnode;
  815. cwithnode := twithnode;
  816. end.
  817. {
  818. $Log$
  819. Revision 1.17 2001-04-13 01:22:10 peter
  820. * symtable change to classes
  821. * range check generation and errors fixed, make cycle DEBUG=1 works
  822. * memory leaks fixed
  823. Revision 1.16 2001/04/02 21:20:31 peter
  824. * resulttype rewrite
  825. Revision 1.15 2001/03/23 00:16:07 florian
  826. + some stuff to compile FreeCLX added
  827. Revision 1.14 2000/12/31 11:14:11 jonas
  828. + implemented/fixed docompare() mathods for all nodes (not tested)
  829. + nopt.pas, nadd.pas, i386/n386opt.pas: optimized nodes for adding strings
  830. and constant strings/chars together
  831. * n386add.pas: don't copy temp strings (of size 256) to another temp string
  832. when adding
  833. Revision 1.13 2000/12/25 00:07:26 peter
  834. + new tlinkedlist class (merge of old tstringqueue,tcontainer and
  835. tlinkedlist objects)
  836. Revision 1.12 2000/12/05 15:19:50 jonas
  837. * fixed webbug 1268 ("merged")
  838. Revision 1.11 2000/11/29 00:30:34 florian
  839. * unused units removed from uses clause
  840. * some changes for widestrings
  841. Revision 1.10 2000/11/04 14:25:20 florian
  842. + merged Attila's changes for interfaces, not tested yet
  843. Revision 1.9 2000/10/31 22:02:49 peter
  844. * symtable splitted, no real code changes
  845. Revision 1.8 2000/10/21 18:16:11 florian
  846. * a lot of changes:
  847. - basic dyn. array support
  848. - basic C++ support
  849. - some work for interfaces done
  850. ....
  851. Revision 1.7 2000/10/14 21:52:55 peter
  852. * fixed memory leaks
  853. Revision 1.6 2000/10/14 10:14:51 peter
  854. * moehrendorf oct 2000 rewrite
  855. Revision 1.5 2000/10/01 19:48:24 peter
  856. * lot of compile updates for cg11
  857. Revision 1.4 2000/09/28 19:49:52 florian
  858. *** empty log message ***
  859. Revision 1.3 2000/09/25 15:37:14 florian
  860. * more fixes
  861. Revision 1.2 2000/09/25 15:05:25 florian
  862. * some updates
  863. Revision 1.1 2000/09/25 09:58:22 florian
  864. * first revision for testing purpose
  865. }