nmem.pas 35 KB

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