pstatmnt.pas 44 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Florian Klaempfl
  4. Does the parsing of the statements
  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 pstatmnt;
  19. {$i fpcdefs.inc}
  20. interface
  21. uses
  22. tokens,node;
  23. function statement_block(starttoken : ttoken) : tnode;
  24. { reads an assembler block }
  25. function assembler_block : tnode;
  26. implementation
  27. uses
  28. { common }
  29. cutils,
  30. { global }
  31. globtype,globals,verbose,
  32. systems,
  33. { aasm }
  34. cpubase,aasmbase,aasmtai,
  35. { symtable }
  36. symconst,symbase,symtype,symdef,symsym,symtable,defutil,defcmp,
  37. paramgr,symutil,
  38. { pass 1 }
  39. pass_1,htypechk,
  40. nutils,nbas,nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,
  41. { parser }
  42. scanner,
  43. pbase,pexpr,
  44. { codegen }
  45. procinfo,cgbase,
  46. { assembler reader }
  47. rabase
  48. ;
  49. function statement : tnode;forward;
  50. function if_statement : tnode;
  51. var
  52. ex,if_a,else_a : tnode;
  53. begin
  54. consume(_IF);
  55. ex:=comp_expr(true);
  56. consume(_THEN);
  57. if token<>_ELSE then
  58. if_a:=statement
  59. else
  60. if_a:=nil;
  61. if try_to_consume(_ELSE) then
  62. else_a:=statement
  63. else
  64. else_a:=nil;
  65. if_statement:=genloopnode(ifn,ex,if_a,else_a,false);
  66. end;
  67. { creates a block (list) of statements, til the next END token }
  68. function statements_til_end : tnode;
  69. var
  70. first,last : tstatementnode;
  71. begin
  72. first:=nil;
  73. while token<>_END do
  74. begin
  75. if first=nil then
  76. begin
  77. last:=cstatementnode.create(statement,nil);
  78. first:=last;
  79. end
  80. else
  81. begin
  82. last.right:=cstatementnode.create(statement,nil);
  83. last:=tstatementnode(last.right);
  84. end;
  85. if not try_to_consume(_SEMICOLON) then
  86. break;
  87. consume_emptystats;
  88. end;
  89. consume(_END);
  90. statements_til_end:=cblocknode.create(first);
  91. end;
  92. function case_statement : tnode;
  93. var
  94. { contains the label number of currently parsed case block }
  95. aktcaselabel : tasmlabel;
  96. firstlabel : boolean;
  97. root : pcaserecord;
  98. { the typ of the case expression }
  99. casedef : tdef;
  100. procedure newcaselabel(l,h : TConstExprInt;first:boolean);
  101. var
  102. hcaselabel : pcaserecord;
  103. procedure insertlabel(var p : pcaserecord);
  104. begin
  105. if p=nil then p:=hcaselabel
  106. else
  107. if (p^._low>hcaselabel^._low) and
  108. (p^._low>hcaselabel^._high) then
  109. if (hcaselabel^.statement = p^.statement) and
  110. (p^._low = hcaselabel^._high + 1) then
  111. begin
  112. p^._low := hcaselabel^._low;
  113. dispose(hcaselabel);
  114. end
  115. else
  116. insertlabel(p^.less)
  117. else
  118. if (p^._high<hcaselabel^._low) and
  119. (p^._high<hcaselabel^._high) then
  120. if (hcaselabel^.statement = p^.statement) and
  121. (p^._high+1 = hcaselabel^._low) then
  122. begin
  123. p^._high := hcaselabel^._high;
  124. dispose(hcaselabel);
  125. end
  126. else
  127. insertlabel(p^.greater)
  128. else Message(parser_e_double_caselabel);
  129. end;
  130. begin
  131. new(hcaselabel);
  132. hcaselabel^.less:=nil;
  133. hcaselabel^.greater:=nil;
  134. hcaselabel^.statement:=aktcaselabel;
  135. hcaselabel^.firstlabel:=first;
  136. objectlibrary.getlabel(hcaselabel^._at);
  137. hcaselabel^._low:=l;
  138. hcaselabel^._high:=h;
  139. insertlabel(root);
  140. end;
  141. var
  142. code,caseexpr,p,instruc,elseblock : tnode;
  143. hl1,hl2 : TConstExprInt;
  144. casedeferror : boolean;
  145. begin
  146. consume(_CASE);
  147. caseexpr:=comp_expr(true);
  148. { determines result type }
  149. do_resulttypepass(caseexpr);
  150. set_varstate(caseexpr,vs_used,true);
  151. casedeferror:=false;
  152. casedef:=caseexpr.resulttype.def;
  153. if (not assigned(casedef)) or
  154. not(is_ordinal(casedef)) then
  155. begin
  156. CGMessage(type_e_ordinal_expr_expected);
  157. { create a correct tree }
  158. caseexpr.free;
  159. caseexpr:=cordconstnode.create(0,u32inttype,false);
  160. { set error flag so no rangechecks are done }
  161. casedeferror:=true;
  162. end;
  163. consume(_OF);
  164. root:=nil;
  165. instruc:=nil;
  166. repeat
  167. objectlibrary.getlabel(aktcaselabel);
  168. firstlabel:=true;
  169. { maybe an instruction has more case labels }
  170. repeat
  171. p:=expr;
  172. if is_widechar(casedef) then
  173. begin
  174. if (p.nodetype=rangen) then
  175. begin
  176. trangenode(p).left:=ctypeconvnode.create(trangenode(p).left,cwidechartype);
  177. trangenode(p).right:=ctypeconvnode.create(trangenode(p).right,cwidechartype);
  178. do_resulttypepass(trangenode(p).left);
  179. do_resulttypepass(trangenode(p).right);
  180. end
  181. else
  182. begin
  183. p:=ctypeconvnode.create(p,cwidechartype);
  184. do_resulttypepass(p);
  185. end;
  186. end;
  187. hl1:=0;
  188. hl2:=0;
  189. if (p.nodetype=rangen) then
  190. begin
  191. { type checking for case statements }
  192. if is_subequal(casedef, trangenode(p).left.resulttype.def) and
  193. is_subequal(casedef, trangenode(p).right.resulttype.def) then
  194. begin
  195. hl1:=get_ordinal_value(trangenode(p).left);
  196. hl2:=get_ordinal_value(trangenode(p).right);
  197. if hl1>hl2 then
  198. CGMessage(parser_e_case_lower_less_than_upper_bound);
  199. if not casedeferror then
  200. begin
  201. testrange(casedef,hl1,false);
  202. testrange(casedef,hl2,false);
  203. end;
  204. end
  205. else
  206. CGMessage(parser_e_case_mismatch);
  207. newcaselabel(hl1,hl2,firstlabel);
  208. end
  209. else
  210. begin
  211. { type checking for case statements }
  212. if not is_subequal(casedef, p.resulttype.def) then
  213. CGMessage(parser_e_case_mismatch);
  214. hl1:=get_ordinal_value(p);
  215. if not casedeferror then
  216. testrange(casedef,hl1,false);
  217. newcaselabel(hl1,hl1,firstlabel);
  218. end;
  219. p.free;
  220. if token=_COMMA then
  221. consume(_COMMA)
  222. else
  223. break;
  224. firstlabel:=false;
  225. until false;
  226. consume(_COLON);
  227. { handles instruction block }
  228. p:=clabelnode.createcase(aktcaselabel,statement);
  229. { concats instruction }
  230. instruc:=cstatementnode.create(p,instruc);
  231. if not(token in [_ELSE,_OTHERWISE,_END]) then
  232. consume(_SEMICOLON);
  233. until (token in [_ELSE,_OTHERWISE,_END]);
  234. if (token in [_ELSE,_OTHERWISE]) then
  235. begin
  236. if not try_to_consume(_ELSE) then
  237. consume(_OTHERWISE);
  238. elseblock:=statements_til_end;
  239. end
  240. else
  241. begin
  242. elseblock:=nil;
  243. consume(_END);
  244. end;
  245. code:=ccasenode.create(caseexpr,instruc,root);
  246. tcasenode(code).elseblock:=elseblock;
  247. case_statement:=code;
  248. end;
  249. function repeat_statement : tnode;
  250. var
  251. first,last,p_e : tnode;
  252. begin
  253. consume(_REPEAT);
  254. first:=nil;
  255. while token<>_UNTIL do
  256. begin
  257. if first=nil then
  258. begin
  259. last:=cstatementnode.create(statement,nil);
  260. first:=last;
  261. end
  262. else
  263. begin
  264. tstatementnode(last).right:=cstatementnode.create(statement,nil);
  265. last:=tstatementnode(last).right;
  266. end;
  267. if not try_to_consume(_SEMICOLON) then
  268. break;
  269. consume_emptystats;
  270. end;
  271. consume(_UNTIL);
  272. first:=cblocknode.create(first);
  273. p_e:=comp_expr(true);
  274. repeat_statement:=genloopnode(whilerepeatn,p_e,first,nil,true);
  275. end;
  276. function while_statement : tnode;
  277. var
  278. p_e,p_a : tnode;
  279. begin
  280. consume(_WHILE);
  281. p_e:=comp_expr(true);
  282. consume(_DO);
  283. p_a:=statement;
  284. while_statement:=genloopnode(whilerepeatn,p_e,p_a,nil,false);
  285. end;
  286. function for_statement : tnode;
  287. var
  288. p_e,tovalue,p_a : tnode;
  289. backward : boolean;
  290. loopvarsym : tabstractvarsym;
  291. hp : tnode;
  292. begin
  293. { parse loop header }
  294. consume(_FOR);
  295. p_e:=expr;
  296. { Check loop variable }
  297. hp:=nil;
  298. loopvarsym:=nil;
  299. if (p_e.nodetype=assignn) then
  300. begin
  301. hp:=tassignmentnode(p_e).left;
  302. { variable must be an ordinal, int64 is not allowed for 32bit targets }
  303. if not(is_ordinal(hp.resulttype.def))
  304. {$ifndef cpu64bit}
  305. or is_64bitint(hp.resulttype.def)
  306. {$endif cpu64bit}
  307. then
  308. MessagePos(hp.fileinfo,type_e_ordinal_expr_expected);
  309. while assigned(hp) and
  310. (
  311. { record/object fields are allowed }
  312. (
  313. (hp.nodetype=subscriptn) and
  314. ((tsubscriptnode(hp).left.resulttype.def.deftype=recorddef) or
  315. is_object(tsubscriptnode(hp).left.resulttype.def))
  316. ) or
  317. { constant array index }
  318. (
  319. (hp.nodetype=vecn) and
  320. is_constintnode(tvecnode(hp).right)
  321. ) or
  322. { equal typeconversions }
  323. (
  324. (hp.nodetype=typeconvn) and
  325. (ttypeconvnode(hp).convtype=tc_equal)
  326. )
  327. ) do
  328. begin
  329. { Use the recordfield for loopvarsym }
  330. if not assigned(loopvarsym) and
  331. (hp.nodetype=subscriptn) then
  332. loopvarsym:=tsubscriptnode(hp).vs;
  333. hp:=tunarynode(hp).left;
  334. end;
  335. if assigned(hp) and
  336. (hp.nodetype=loadn) then
  337. begin
  338. case tloadnode(hp).symtableentry.typ of
  339. globalvarsym,
  340. localvarsym,
  341. paravarsym :
  342. begin
  343. { we need a simple loadn and the load must be in a global symtable or
  344. in the same level as the para of the current proc }
  345. if (
  346. (tloadnode(hp).symtable.symtablelevel=main_program_level) or
  347. (tloadnode(hp).symtable.symtablelevel=current_procinfo.procdef.parast.symtablelevel)
  348. ) and
  349. not(
  350. ((tabstractvarsym(tloadnode(hp).symtableentry).varspez in [vs_var,vs_out]) or
  351. (vo_is_thread_var in tabstractvarsym(tloadnode(hp).symtableentry).varoptions))
  352. ) then
  353. begin
  354. tabstractvarsym(tloadnode(hp).symtableentry).varstate:=vs_used;
  355. { Assigning for-loop variable is only allowed in tp7 }
  356. if not(m_tp7 in aktmodeswitches) then
  357. begin
  358. if not assigned(loopvarsym) then
  359. loopvarsym:=tabstractvarsym(tloadnode(hp).symtableentry);
  360. include(loopvarsym.varoptions,vo_is_loop_counter);
  361. end;
  362. end
  363. else
  364. MessagePos(hp.fileinfo,type_e_illegal_count_var);
  365. end;
  366. typedconstsym :
  367. begin
  368. { Bad programming, only allowed in tp7 mode }
  369. if not(m_tp7 in aktmodeswitches) then
  370. MessagePos(hp.fileinfo,type_e_illegal_count_var);
  371. end;
  372. else
  373. MessagePos(hp.fileinfo,type_e_illegal_count_var);
  374. end;
  375. end
  376. else
  377. MessagePos(tassignmentnode(p_e).left.fileinfo,type_e_illegal_count_var);
  378. end
  379. else
  380. Message(parser_e_illegal_expression);
  381. if token=_DOWNTO then
  382. begin
  383. consume(_DOWNTO);
  384. backward:=true;
  385. end
  386. else
  387. begin
  388. consume(_TO);
  389. backward:=false;
  390. end;
  391. tovalue:=comp_expr(true);
  392. consume(_DO);
  393. { ... now the instruction block }
  394. p_a:=statement;
  395. { variable is not used a loop counter anymore }
  396. if assigned(loopvarsym) then
  397. exclude(loopvarsym.varoptions,vo_is_loop_counter);
  398. for_statement:=genloopnode(forn,p_e,tovalue,p_a,backward);
  399. end;
  400. function _with_statement : tnode;
  401. var
  402. right,p : tnode;
  403. i,levelcount : longint;
  404. withsymtable,symtab : tsymtable;
  405. obj : tobjectdef;
  406. hp : tnode;
  407. newblock : tblocknode;
  408. newstatement : tstatementnode;
  409. calltempp,
  410. loadp : ttempcreatenode;
  411. refp : tnode;
  412. htype : ttype;
  413. hasimplicitderef : boolean;
  414. begin
  415. p:=comp_expr(true);
  416. do_resulttypepass(p);
  417. set_varstate(p,vs_used,false);
  418. right:=nil;
  419. if (not codegenerror) and
  420. (p.resulttype.def.deftype in [objectdef,recorddef]) then
  421. begin
  422. newblock:=nil;
  423. { ignore nodes that don't add instructions in the tree }
  424. hp:=p;
  425. while { equal type conversions }
  426. (
  427. (hp.nodetype=typeconvn) and
  428. (ttypeconvnode(hp).convtype=tc_equal)
  429. ) or
  430. { constant array index }
  431. (
  432. (hp.nodetype=vecn) and
  433. (tvecnode(hp).right.nodetype=ordconstn)
  434. ) do
  435. hp:=tunarynode(hp).left;
  436. if (hp.nodetype=loadn) and
  437. (
  438. (tloadnode(hp).symtable=current_procinfo.procdef.localst) or
  439. (tloadnode(hp).symtable=current_procinfo.procdef.parast) or
  440. (tloadnode(hp).symtable.symtabletype in [staticsymtable,globalsymtable])
  441. ) then
  442. begin
  443. { simple load, we can reference direct }
  444. loadp:=nil;
  445. refp:=p;
  446. end
  447. else
  448. begin
  449. calltempp:=nil;
  450. { complex load, load in temp first }
  451. newblock:=internalstatements(newstatement);
  452. { when right is a call then load it first in a temp }
  453. if p.nodetype=calln then
  454. begin
  455. calltempp:=ctempcreatenode.create(p.resulttype,p.resulttype.def.size,tt_persistent);
  456. addstatement(newstatement,calltempp);
  457. addstatement(newstatement,cassignmentnode.create(
  458. ctemprefnode.create(calltempp),
  459. p));
  460. p:=ctemprefnode.create(calltempp);
  461. resulttypepass(p);
  462. end;
  463. { classes and interfaces have implicit dereferencing }
  464. hasimplicitderef:=is_class_or_interface(p.resulttype.def);
  465. if hasimplicitderef then
  466. htype:=p.resulttype
  467. else
  468. htype.setdef(tpointerdef.create(p.resulttype));
  469. {$ifdef WITHNODEDEBUG}
  470. { we can't generate debuginfo for a withnode stored in a }
  471. { register }
  472. if (cs_debuginfo in aktmoduleswitches) then
  473. loadp:=ctempcreatenode.create(htype,sizeof(aint),tt_persistent)
  474. else
  475. {$endif WITHNODEDEBUG}
  476. loadp:=ctempcreatenode.create_reg(htype,sizeof(aint),tt_persistent);
  477. resulttypepass(loadp);
  478. if hasimplicitderef then
  479. begin
  480. hp:=p;
  481. refp:=ctemprefnode.create(loadp);
  482. end
  483. else
  484. begin
  485. hp:=caddrnode.create(p);
  486. refp:=cderefnode.create(ctemprefnode.create(loadp));
  487. end;
  488. addstatement(newstatement,loadp);
  489. addstatement(newstatement,cassignmentnode.create(
  490. ctemprefnode.create(loadp),
  491. hp));
  492. resulttypepass(refp);
  493. end;
  494. case p.resulttype.def.deftype of
  495. objectdef :
  496. begin
  497. obj:=tobjectdef(p.resulttype.def);
  498. withsymtable:=twithsymtable.Create(obj,obj.symtable.symsearch,refp);
  499. { include also all parent symtables }
  500. levelcount:=1;
  501. obj:=obj.childof;
  502. symtab:=withsymtable;
  503. while assigned(obj) do
  504. begin
  505. { keep the original tobjectdef as owner, because that is used for
  506. visibility of the symtable }
  507. symtab.next:=twithsymtable.create(tobjectdef(p.resulttype.def),obj.symtable.symsearch,refp.getcopy);
  508. symtab:=symtab.next;
  509. obj:=obj.childof;
  510. inc(levelcount);
  511. end;
  512. symtab.next:=symtablestack;
  513. symtablestack:=withsymtable;
  514. end;
  515. recorddef :
  516. begin
  517. symtab:=trecorddef(p.resulttype.def).symtable;
  518. levelcount:=1;
  519. withsymtable:=twithsymtable.create(trecorddef(p.resulttype.def),symtab.symsearch,refp);
  520. withsymtable.next:=symtablestack;
  521. symtablestack:=withsymtable;
  522. end;
  523. end;
  524. if try_to_consume(_COMMA) then
  525. right:=_with_statement()
  526. else
  527. begin
  528. consume(_DO);
  529. if token<>_SEMICOLON then
  530. right:=statement
  531. else
  532. right:=cerrornode.create;
  533. end;
  534. { remove symtables from the stack }
  535. for i:=1 to levelcount do
  536. symtablestack:=symtablestack.next;
  537. p:=cwithnode.create(right,twithsymtable(withsymtable),levelcount,refp);
  538. { Finalize complex withnode with destroy of temp }
  539. if assigned(newblock) then
  540. begin
  541. addstatement(newstatement,p);
  542. addstatement(newstatement,ctempdeletenode.create(loadp));
  543. if assigned(calltempp) then
  544. addstatement(newstatement,ctempdeletenode.create(calltempp));
  545. p:=newblock;
  546. end;
  547. _with_statement:=p;
  548. end
  549. else
  550. begin
  551. p.free;
  552. Message(parser_e_false_with_expr);
  553. { try to recover from error }
  554. if try_to_consume(_COMMA) then
  555. begin
  556. hp:=_with_statement();
  557. if (hp=nil) then; { remove warning about unused }
  558. end
  559. else
  560. begin
  561. consume(_DO);
  562. { ignore all }
  563. if token<>_SEMICOLON then
  564. statement;
  565. end;
  566. _with_statement:=nil;
  567. end;
  568. end;
  569. function with_statement : tnode;
  570. begin
  571. consume(_WITH);
  572. with_statement:=_with_statement();
  573. end;
  574. function raise_statement : tnode;
  575. var
  576. p,pobj,paddr,pframe : tnode;
  577. begin
  578. pobj:=nil;
  579. paddr:=nil;
  580. pframe:=nil;
  581. consume(_RAISE);
  582. if not(token in endtokens) then
  583. begin
  584. { object }
  585. pobj:=comp_expr(true);
  586. if try_to_consume(_AT) then
  587. begin
  588. paddr:=comp_expr(true);
  589. if try_to_consume(_COMMA) then
  590. pframe:=comp_expr(true);
  591. end;
  592. end
  593. else
  594. begin
  595. if (block_type<>bt_except) then
  596. Message(parser_e_no_reraise_possible);
  597. end;
  598. p:=craisenode.create(pobj,paddr,pframe);
  599. raise_statement:=p;
  600. end;
  601. function try_statement : tnode;
  602. var
  603. p_try_block,p_finally_block,first,last,
  604. p_default,p_specific,hp : tnode;
  605. ot : ttype;
  606. sym : tlocalvarsym;
  607. old_block_type : tblock_type;
  608. exceptsymtable : tsymtable;
  609. objname,objrealname : stringid;
  610. srsym : tsym;
  611. srsymtable : tsymtable;
  612. oldaktexceptblock: integer;
  613. begin
  614. include(current_procinfo.flags,pi_uses_exceptions);
  615. p_default:=nil;
  616. p_specific:=nil;
  617. { read statements to try }
  618. consume(_TRY);
  619. first:=nil;
  620. inc(exceptblockcounter);
  621. oldaktexceptblock := aktexceptblock;
  622. aktexceptblock := exceptblockcounter;
  623. while (token<>_FINALLY) and (token<>_EXCEPT) do
  624. begin
  625. if first=nil then
  626. begin
  627. last:=cstatementnode.create(statement,nil);
  628. first:=last;
  629. end
  630. else
  631. begin
  632. tstatementnode(last).right:=cstatementnode.create(statement,nil);
  633. last:=tstatementnode(last).right;
  634. end;
  635. if not try_to_consume(_SEMICOLON) then
  636. break;
  637. consume_emptystats;
  638. end;
  639. p_try_block:=cblocknode.create(first);
  640. if try_to_consume(_FINALLY) then
  641. begin
  642. inc(exceptblockcounter);
  643. aktexceptblock := exceptblockcounter;
  644. p_finally_block:=statements_til_end;
  645. try_statement:=ctryfinallynode.create(p_try_block,p_finally_block);
  646. end
  647. else
  648. begin
  649. consume(_EXCEPT);
  650. old_block_type:=block_type;
  651. block_type:=bt_except;
  652. inc(exceptblockcounter);
  653. aktexceptblock := exceptblockcounter;
  654. ot:=generrortype;
  655. p_specific:=nil;
  656. if (idtoken=_ON) then
  657. { catch specific exceptions }
  658. begin
  659. repeat
  660. consume(_ID);
  661. if token=_ID then
  662. begin
  663. objname:=pattern;
  664. objrealname:=orgpattern;
  665. { can't use consume_sym here, because we need already
  666. to check for the colon }
  667. searchsym(objname,srsym,srsymtable);
  668. consume(_ID);
  669. { is a explicit name for the exception given ? }
  670. if try_to_consume(_COLON) then
  671. begin
  672. consume_sym(srsym,srsymtable);
  673. if (srsym.typ=typesym) and
  674. is_class(ttypesym(srsym).restype.def) then
  675. begin
  676. ot:=ttypesym(srsym).restype;
  677. sym:=tlocalvarsym.create(objrealname,vs_value,ot);
  678. end
  679. else
  680. begin
  681. sym:=tlocalvarsym.create(objrealname,vs_value,generrortype);
  682. if (srsym.typ=typesym) then
  683. Message1(type_e_class_type_expected,ttypesym(srsym).restype.def.typename)
  684. else
  685. Message1(type_e_class_type_expected,ot.def.typename);
  686. end;
  687. exceptsymtable:=tstt_exceptsymtable.create;
  688. exceptsymtable.insert(sym);
  689. { insert the exception symtable stack }
  690. exceptsymtable.next:=symtablestack;
  691. symtablestack:=exceptsymtable;
  692. end
  693. else
  694. begin
  695. { check if type is valid, must be done here because
  696. with "e: Exception" the e is not necessary }
  697. if srsym=nil then
  698. begin
  699. identifier_not_found(objrealname);
  700. srsym:=generrorsym;
  701. end;
  702. { support unit.identifier }
  703. if srsym.typ=unitsym then
  704. begin
  705. consume(_POINT);
  706. srsym:=searchsymonlyin(tunitsym(srsym).unitsymtable,pattern);
  707. if srsym=nil then
  708. begin
  709. identifier_not_found(orgpattern);
  710. srsym:=generrorsym;
  711. end;
  712. consume(_ID);
  713. end;
  714. { check if type is valid, must be done here because
  715. with "e: Exception" the e is not necessary }
  716. if (srsym.typ=typesym) and
  717. is_class(ttypesym(srsym).restype.def) then
  718. ot:=ttypesym(srsym).restype
  719. else
  720. begin
  721. ot:=generrortype;
  722. if (srsym.typ=typesym) then
  723. Message1(type_e_class_type_expected,ttypesym(srsym).restype.def.typename)
  724. else
  725. Message1(type_e_class_type_expected,ot.def.typename);
  726. end;
  727. exceptsymtable:=nil;
  728. end;
  729. end
  730. else
  731. consume(_ID);
  732. consume(_DO);
  733. hp:=connode.create(nil,statement);
  734. if ot.def.deftype=errordef then
  735. begin
  736. hp.free;
  737. hp:=cerrornode.create;
  738. end;
  739. if p_specific=nil then
  740. begin
  741. last:=hp;
  742. p_specific:=last;
  743. end
  744. else
  745. begin
  746. tonnode(last).left:=hp;
  747. last:=tonnode(last).left;
  748. end;
  749. { set the informations }
  750. { only if the creation of the onnode was succesful, it's possible }
  751. { that last and hp are errornodes (JM) }
  752. if last.nodetype = onn then
  753. begin
  754. tonnode(last).excepttype:=tobjectdef(ot.def);
  755. tonnode(last).exceptsymtable:=exceptsymtable;
  756. end;
  757. { remove exception symtable }
  758. if assigned(exceptsymtable) then
  759. begin
  760. symtablestack:=symtablestack.next;
  761. if last.nodetype <> onn then
  762. exceptsymtable.free;
  763. end;
  764. if not try_to_consume(_SEMICOLON) then
  765. break;
  766. consume_emptystats;
  767. until (token in [_END,_ELSE]);
  768. if try_to_consume(_ELSE) then
  769. begin
  770. { catch the other exceptions }
  771. p_default:=statements_til_end;
  772. end
  773. else
  774. consume(_END);
  775. end
  776. else
  777. begin
  778. { catch all exceptions }
  779. p_default:=statements_til_end;
  780. end;
  781. block_type:=old_block_type;
  782. try_statement:=ctryexceptnode.create(p_try_block,p_specific,p_default);
  783. end;
  784. aktexceptblock := oldaktexceptblock;
  785. end;
  786. function _asm_statement : tnode;
  787. var
  788. asmstat : tasmnode;
  789. Marker : tai;
  790. reg : tregister;
  791. asmreader : tbaseasmreader;
  792. begin
  793. Inside_asm_statement:=true;
  794. if assigned(asmmodeinfos[aktasmmode]) then
  795. begin
  796. asmreader:=asmmodeinfos[aktasmmode]^.casmreader.create;
  797. asmstat:=casmnode.create(asmreader.assemble as taasmoutput);
  798. asmreader.free;
  799. end
  800. else
  801. Message(parser_f_assembler_reader_not_supported);
  802. { Mark procedure that it has assembler blocks }
  803. include(current_procinfo.flags,pi_has_assembler_block);
  804. { Read first the _ASM statement }
  805. consume(_ASM);
  806. { END is read, got a list of changed registers? }
  807. if try_to_consume(_LECKKLAMMER) then
  808. begin
  809. asmstat.used_regs_fpu:=[0..first_fpu_imreg-1];
  810. if token<>_RECKKLAMMER then
  811. begin
  812. repeat
  813. { it's possible to specify the modified registers }
  814. reg:=std_regnum_search(lower(pattern));
  815. if reg<>NR_NO then
  816. begin
  817. if getregtype(reg)=R_INTREGISTER then
  818. include(asmstat.used_regs_int,getsupreg(reg));
  819. end
  820. else
  821. Message(asmr_e_invalid_register);
  822. consume(_CSTRING);
  823. if not try_to_consume(_COMMA) then
  824. break;
  825. until false;
  826. end;
  827. consume(_RECKKLAMMER);
  828. end
  829. else
  830. begin
  831. asmstat.used_regs_int:=paramanager.get_volatile_registers_int(current_procinfo.procdef.proccalloption);
  832. asmstat.used_regs_fpu:=paramanager.get_volatile_registers_fpu(current_procinfo.procdef.proccalloption);
  833. end;
  834. { mark the start and the end of the assembler block
  835. this is needed for the optimizer }
  836. If Assigned(AsmStat.p_asm) Then
  837. Begin
  838. Marker := Tai_Marker.Create(AsmBlockStart);
  839. AsmStat.p_asm.Insert(Marker);
  840. Marker := Tai_Marker.Create(AsmBlockEnd);
  841. AsmStat.p_asm.Concat(Marker);
  842. End;
  843. Inside_asm_statement:=false;
  844. _asm_statement:=asmstat;
  845. end;
  846. function statement : tnode;
  847. var
  848. p : tnode;
  849. code : tnode;
  850. filepos : tfileposinfo;
  851. srsym : tsym;
  852. srsymtable : tsymtable;
  853. s : stringid;
  854. begin
  855. filepos:=akttokenpos;
  856. case token of
  857. _GOTO :
  858. begin
  859. if not(cs_support_goto in aktmoduleswitches)then
  860. Message(sym_e_goto_and_label_not_supported);
  861. consume(_GOTO);
  862. if (token<>_INTCONST) and (token<>_ID) then
  863. begin
  864. Message(sym_e_label_not_found);
  865. code:=cerrornode.create;
  866. end
  867. else
  868. begin
  869. if token=_ID then
  870. consume_sym(srsym,srsymtable)
  871. else
  872. begin
  873. searchsym(pattern,srsym,srsymtable);
  874. if srsym=nil then
  875. begin
  876. identifier_not_found(pattern);
  877. srsym:=generrorsym;
  878. srsymtable:=nil;
  879. end;
  880. consume(token);
  881. end;
  882. if srsym.typ<>labelsym then
  883. begin
  884. Message(sym_e_id_is_no_label_id);
  885. code:=cerrornode.create;
  886. end
  887. else
  888. begin
  889. { goto is only allowed to labels within the current scope }
  890. if srsym.owner<>current_procinfo.procdef.localst then
  891. CGMessage(parser_e_goto_outside_proc);
  892. code:=cgotonode.create(tlabelsym(srsym));
  893. tgotonode(code).labsym:=tlabelsym(srsym);
  894. { set flag that this label is used }
  895. tlabelsym(srsym).used:=true;
  896. end;
  897. end;
  898. end;
  899. _BEGIN :
  900. code:=statement_block(_BEGIN);
  901. _IF :
  902. code:=if_statement;
  903. _CASE :
  904. code:=case_statement;
  905. _REPEAT :
  906. code:=repeat_statement;
  907. _WHILE :
  908. code:=while_statement;
  909. _FOR :
  910. code:=for_statement;
  911. _WITH :
  912. code:=with_statement;
  913. _TRY :
  914. code:=try_statement;
  915. _RAISE :
  916. code:=raise_statement;
  917. { semicolons,else until and end are ignored }
  918. _SEMICOLON,
  919. _ELSE,
  920. _UNTIL,
  921. _END:
  922. code:=cnothingnode.create;
  923. _FAIL :
  924. begin
  925. if (current_procinfo.procdef.proctypeoption<>potype_constructor) then
  926. Message(parser_e_fail_only_in_constructor);
  927. consume(_FAIL);
  928. code:=call_fail_node;
  929. end;
  930. _ASM :
  931. code:=_asm_statement;
  932. _EOF :
  933. Message(scan_f_end_of_file);
  934. else
  935. begin
  936. p:=expr;
  937. { When a colon follows a intconst then transform it into a label }
  938. if (p.nodetype=ordconstn) and
  939. try_to_consume(_COLON) then
  940. begin
  941. s:=tostr(tordconstnode(p).value);
  942. p.free;
  943. searchsym(s,srsym,srsymtable);
  944. if assigned(srsym) and
  945. (srsym.typ=labelsym) then
  946. begin
  947. if tlabelsym(srsym).defined then
  948. Message(sym_e_label_already_defined);
  949. tlabelsym(srsym).defined:=true;
  950. p:=clabelnode.create(tlabelsym(srsym),nil);
  951. end
  952. else
  953. begin
  954. Message1(sym_e_label_used_and_not_defined,s);
  955. p:=cnothingnode.create;
  956. end;
  957. end;
  958. if p.nodetype=labeln then
  959. begin
  960. { the pointer to the following instruction }
  961. { isn't a very clean way }
  962. if token in endtokens then
  963. tlabelnode(p).left:=cnothingnode.create
  964. else
  965. tlabelnode(p).left:=statement();
  966. { be sure to have left also resulttypepass }
  967. resulttypepass(tlabelnode(p).left);
  968. end
  969. else
  970. { change a load of a procvar to a call. this is also
  971. supported in fpc mode }
  972. if p.nodetype in [vecn,derefn,typeconvn,subscriptn,loadn] then
  973. maybe_call_procvar(p,false);
  974. { blockn support because a read/write is changed into a blocknode }
  975. { with a separate statement for each read/write operation (JM) }
  976. { the same is true for val() if the third parameter is not 32 bit }
  977. if not(p.nodetype in [nothingn,calln,ifn,assignn,breakn,inlinen,
  978. continuen,labeln,blockn,exitn]) then
  979. Message(parser_e_illegal_expression);
  980. { Specify that we don't use the value returned by the call.
  981. This is used for :
  982. - dispose of temp stack space
  983. - dispose on FPU stack }
  984. if (p.nodetype=calln) then
  985. exclude(tcallnode(p).callnodeflags,cnf_return_value_used);
  986. code:=p;
  987. end;
  988. end;
  989. if assigned(code) then
  990. code.set_tree_filepos(filepos);
  991. statement:=code;
  992. end;
  993. function statement_block(starttoken : ttoken) : tnode;
  994. var
  995. first,last : tnode;
  996. filepos : tfileposinfo;
  997. begin
  998. first:=nil;
  999. filepos:=akttokenpos;
  1000. consume(starttoken);
  1001. while not(token in [_END,_FINALIZATION]) do
  1002. begin
  1003. if first=nil then
  1004. begin
  1005. last:=cstatementnode.create(statement,nil);
  1006. first:=last;
  1007. end
  1008. else
  1009. begin
  1010. tstatementnode(last).right:=cstatementnode.create(statement,nil);
  1011. last:=tstatementnode(last).right;
  1012. end;
  1013. if (token in [_END,_FINALIZATION]) then
  1014. break
  1015. else
  1016. begin
  1017. { if no semicolon, then error and go on }
  1018. if token<>_SEMICOLON then
  1019. begin
  1020. consume(_SEMICOLON);
  1021. consume_all_until(_SEMICOLON);
  1022. end;
  1023. consume(_SEMICOLON);
  1024. end;
  1025. consume_emptystats;
  1026. end;
  1027. { don't consume the finalization token, it is consumed when
  1028. reading the finalization block, but allow it only after
  1029. an initalization ! }
  1030. if (starttoken<>_INITIALIZATION) or (token<>_FINALIZATION) then
  1031. consume(_END);
  1032. last:=cblocknode.create(first);
  1033. last.set_tree_filepos(filepos);
  1034. statement_block:=last;
  1035. end;
  1036. function assembler_block : tnode;
  1037. var
  1038. p : tnode;
  1039. locals : longint;
  1040. begin
  1041. { Rename the funcret so that recursive calls are possible }
  1042. if not is_void(current_procinfo.procdef.rettype.def) then
  1043. symtablestack.rename(current_procinfo.procdef.resultname,'$hiddenresult');
  1044. { delphi uses register calling for assembler methods }
  1045. if (m_delphi in aktmodeswitches) and
  1046. (po_assembler in current_procinfo.procdef.procoptions) and
  1047. not(po_hascallingconvention in current_procinfo.procdef.procoptions) then
  1048. current_procinfo.procdef.proccalloption:=pocall_register;
  1049. { force the asm statement }
  1050. if token<>_ASM then
  1051. consume(_ASM);
  1052. include(current_procinfo.flags,pi_is_assembler);
  1053. p:=_asm_statement;
  1054. {$ifndef sparc}
  1055. {$ifndef arm}
  1056. if (po_assembler in current_procinfo.procdef.procoptions) then
  1057. begin
  1058. { set the framepointer to esp for assembler functions when the
  1059. following conditions are met:
  1060. - if the are no local variables and parameters (except the allocated result)
  1061. - no reference to the result variable (refcount<=1)
  1062. - result is not stored as parameter
  1063. - target processor has optional frame pointer save
  1064. (vm, i386, vm only currently)
  1065. }
  1066. locals:=0;
  1067. current_procinfo.procdef.localst.foreach_static(@count_locals,@locals);
  1068. current_procinfo.procdef.parast.foreach_static(@count_locals,@locals);
  1069. if (locals=0) and
  1070. (current_procinfo.procdef.owner.symtabletype<>objectsymtable) and
  1071. (not assigned(current_procinfo.procdef.funcretsym) or
  1072. (tabstractvarsym(current_procinfo.procdef.funcretsym).refcount<=1)) and
  1073. not(paramanager.ret_in_param(current_procinfo.procdef.rettype.def,current_procinfo.procdef.proccalloption)) then
  1074. begin
  1075. { Only need to set the framepointer, the locals will
  1076. be inserted with the correct reference in tcgasmnode.pass_2 }
  1077. current_procinfo.framepointer:=NR_STACK_POINTER_REG;
  1078. end;
  1079. end;
  1080. {$endif arm}
  1081. {$endif sparc}
  1082. { Flag the result as assigned when it is returned in a
  1083. register.
  1084. }
  1085. if assigned(current_procinfo.procdef.funcretsym) and
  1086. (not paramanager.ret_in_param(current_procinfo.procdef.rettype.def,current_procinfo.procdef.proccalloption)) then
  1087. tabstractvarsym(current_procinfo.procdef.funcretsym).varstate:=vs_assigned;
  1088. { because the END is already read we need to get the
  1089. last_endtoken_filepos here (PFV) }
  1090. last_endtoken_filepos:=akttokenpos;
  1091. assembler_block:=p;
  1092. end;
  1093. end.
  1094. {
  1095. $Log$
  1096. Revision 1.144 2004-11-08 22:09:59 peter
  1097. * tvarsym splitted
  1098. Revision 1.143 2004/10/15 10:35:23 mazen
  1099. * remove non needed parathesys as in 1.140
  1100. Revision 1.141 2004/09/27 15:15:52 peter
  1101. * register loopvarsym for fields instead of record variable
  1102. * don't allow class fields as loop var
  1103. Revision 1.140 2004/09/26 17:45:30 peter
  1104. * simple regvar support, not yet finished
  1105. Revision 1.139 2004/09/21 17:25:12 peter
  1106. * paraloc branch merged
  1107. Revision 1.138 2004/09/21 16:00:50 peter
  1108. * no difference for withnode when debuginfo is generated
  1109. Revision 1.137 2004/09/13 20:28:27 peter
  1110. * for loop variable assignment is not allowed anymore
  1111. Revision 1.136.4.1 2004/09/21 16:01:54 peter
  1112. * withnode debug disabled
  1113. Revision 1.136 2004/06/20 08:55:30 florian
  1114. * logs truncated
  1115. Revision 1.135 2004/06/16 20:07:09 florian
  1116. * dwarf branch merged
  1117. Revision 1.134 2004/05/23 18:28:41 peter
  1118. * methodpointer is loaded into a temp when it was a calln
  1119. Revision 1.133 2004/05/23 11:39:38 peter
  1120. * give error when goto jumps to label outside current proc scope
  1121. Revision 1.132.2.2 2004/05/01 16:02:09 peter
  1122. * POINTER_SIZE replaced with sizeof(aint)
  1123. * aint,aword,tconst*int moved to globtype
  1124. Revision 1.132.2.1 2004/04/28 19:55:52 peter
  1125. * new warning for ordinal-pointer when size is different
  1126. * fixed some cg_e_ messages to the correct section type_e_ or parser_e_
  1127. }