pstatmnt.pas 57 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl
  3. Does the parsing of the statements
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit pstatmnt;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. tokens,node;
  22. function statement_block(starttoken : ttoken) : tnode;
  23. { reads an assembler block }
  24. function assembler_block : tnode;
  25. implementation
  26. uses
  27. { common }
  28. cutils,cclasses,
  29. { global }
  30. globtype,globals,verbose,constexp,
  31. systems,
  32. { aasm }
  33. cpubase,aasmtai,aasmdata,
  34. { symtable }
  35. symconst,symbase,symtype,symdef,symsym,symtable,defutil,defcmp,
  36. paramgr,
  37. { pass 1 }
  38. pass_1,htypechk,
  39. nutils,ngenutil,nbas,ncal,nmem,nset,ncnv,ncon,nld,nflw,
  40. { parser }
  41. scanner,
  42. pbase,ptype,pexpr,
  43. { codegen }
  44. procinfo,cgbase,
  45. { assembler reader }
  46. rabase;
  47. function statement : tnode;forward;
  48. function if_statement : tnode;
  49. var
  50. ex,if_a,else_a : tnode;
  51. begin
  52. consume(_IF);
  53. ex:=comp_expr([ef_accept_equal]);
  54. consume(_THEN);
  55. if not(token in endtokens) then
  56. if_a:=statement
  57. else
  58. if_a:=nil;
  59. if try_to_consume(_ELSE) then
  60. else_a:=statement
  61. else
  62. else_a:=nil;
  63. result:=cifnode.create(ex,if_a,else_a);
  64. end;
  65. { creates a block (list) of statements, til the next END token }
  66. function statements_til_end : tnode;
  67. var
  68. first,last : tstatementnode;
  69. begin
  70. first:=nil;
  71. last:=nil;
  72. while token<>_END do
  73. begin
  74. if first=nil then
  75. begin
  76. last:=cstatementnode.create(statement,nil);
  77. first:=last;
  78. end
  79. else
  80. begin
  81. last.right:=cstatementnode.create(statement,nil);
  82. last:=tstatementnode(last.right);
  83. end;
  84. if not try_to_consume(_SEMICOLON) then
  85. break;
  86. consume_emptystats;
  87. end;
  88. consume(_END);
  89. statements_til_end:=cblocknode.create(first);
  90. if assigned(first) then
  91. statements_til_end.fileinfo:=first.fileinfo;
  92. end;
  93. function case_statement : tnode;
  94. var
  95. casedef : tdef;
  96. caseexpr,p : tnode;
  97. blockid : longint;
  98. hl1,hl2 : TConstExprInt;
  99. sl1,sl2 : tstringconstnode;
  100. casedeferror, caseofstring : boolean;
  101. casenode : tcasenode;
  102. begin
  103. consume(_CASE);
  104. caseexpr:=comp_expr([ef_accept_equal]);
  105. { determines result type }
  106. do_typecheckpass(caseexpr);
  107. { variants must be accepted, but first they must be converted to integer }
  108. if caseexpr.resultdef.typ=variantdef then
  109. begin
  110. caseexpr:=ctypeconvnode.create_internal(caseexpr,sinttype);
  111. do_typecheckpass(caseexpr);
  112. end;
  113. set_varstate(caseexpr,vs_read,[vsf_must_be_valid]);
  114. casedeferror:=false;
  115. casedef:=caseexpr.resultdef;
  116. { case of string must be rejected in delphi-, }
  117. { tp7/bp7-, mac-compatibility modes. }
  118. caseofstring :=
  119. ([m_delphi, m_mac, m_tp7] * current_settings.modeswitches = []) and
  120. is_string(casedef);
  121. if (not assigned(casedef)) or
  122. ( not(is_ordinal(casedef)) and (not caseofstring) ) then
  123. begin
  124. CGMessage(type_e_ordinal_or_string_expr_expected);
  125. { create a correct tree }
  126. caseexpr.free;
  127. caseexpr:=cordconstnode.create(0,u32inttype,false);
  128. { set error flag so no rangechecks are done }
  129. casedeferror:=true;
  130. end;
  131. { Create casenode }
  132. casenode:=ccasenode.create(caseexpr);
  133. consume(_OF);
  134. { Parse all case blocks }
  135. blockid:=0;
  136. repeat
  137. { maybe an instruction has more case labels }
  138. repeat
  139. p:=expr(true);
  140. if is_widechar(casedef) then
  141. begin
  142. if (p.nodetype=rangen) then
  143. begin
  144. trangenode(p).left:=ctypeconvnode.create(trangenode(p).left,cwidechartype);
  145. trangenode(p).right:=ctypeconvnode.create(trangenode(p).right,cwidechartype);
  146. do_typecheckpass(trangenode(p).left);
  147. do_typecheckpass(trangenode(p).right);
  148. end
  149. else
  150. begin
  151. p:=ctypeconvnode.create(p,cwidechartype);
  152. do_typecheckpass(p);
  153. end;
  154. end
  155. else
  156. begin
  157. if is_char(casedef) and is_widechar(p.resultdef) then
  158. begin
  159. if (p.nodetype=ordconstn) then
  160. begin
  161. p:=ctypeconvnode.create(p,cansichartype);
  162. do_typecheckpass(p);
  163. end
  164. else if (p.nodetype=rangen) then
  165. begin
  166. trangenode(p).left:=ctypeconvnode.create(trangenode(p).left,cansichartype);
  167. trangenode(p).right:=ctypeconvnode.create(trangenode(p).right,cansichartype);
  168. do_typecheckpass(trangenode(p).left);
  169. do_typecheckpass(trangenode(p).right);
  170. end;
  171. end;
  172. end;
  173. hl1:=0;
  174. hl2:=0;
  175. sl1:=nil;
  176. sl2:=nil;
  177. if (p.nodetype=rangen) then
  178. begin
  179. { type check for string case statements }
  180. if caseofstring and
  181. is_conststring_or_constcharnode(trangenode(p).left) and
  182. is_conststring_or_constcharnode(trangenode(p).right) then
  183. begin
  184. { we need stringconstnodes, even if expression contains single chars }
  185. sl1 := get_string_value(trangenode(p).left, tstringdef(casedef));
  186. sl2 := get_string_value(trangenode(p).right, tstringdef(casedef));
  187. if sl1.fullcompare(sl2) > 0 then
  188. CGMessage(parser_e_case_lower_less_than_upper_bound);
  189. end
  190. { type checking for ordinal case statements }
  191. else if (not caseofstring) and
  192. is_subequal(casedef, trangenode(p).left.resultdef) and
  193. is_subequal(casedef, trangenode(p).right.resultdef) 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. adaptrange(casedef,hl1,false,false,cs_check_range in current_settings.localswitches);
  202. adaptrange(casedef,hl2,false,false,cs_check_range in current_settings.localswitches);
  203. end;
  204. end
  205. else
  206. CGMessage(parser_e_case_mismatch);
  207. if caseofstring then
  208. casenode.addlabel(blockid,sl1,sl2)
  209. else
  210. casenode.addlabel(blockid,hl1,hl2);
  211. end
  212. else
  213. begin
  214. { type check for string case statements }
  215. if (caseofstring and (not is_conststring_or_constcharnode(p))) or
  216. { type checking for ordinal case statements }
  217. ((not caseofstring) and (not is_subequal(casedef, p.resultdef))) then
  218. CGMessage(parser_e_case_mismatch);
  219. if caseofstring then
  220. begin
  221. sl1:=get_string_value(p, tstringdef(casedef));
  222. casenode.addlabel(blockid,sl1,sl1);
  223. end
  224. else
  225. begin
  226. hl1:=get_ordinal_value(p);
  227. if not casedeferror then
  228. adaptrange(casedef,hl1,false,false,cs_check_range in current_settings.localswitches);
  229. casenode.addlabel(blockid,hl1,hl1);
  230. end;
  231. end;
  232. p.free;
  233. sl1.free;
  234. sl2.free;
  235. if token=_COMMA then
  236. consume(_COMMA)
  237. else
  238. break;
  239. until false;
  240. consume(_COLON);
  241. { add instruction block }
  242. casenode.addblock(blockid,statement);
  243. { next block }
  244. inc(blockid);
  245. if not(token in [_ELSE,_OTHERWISE,_END]) then
  246. consume(_SEMICOLON);
  247. until (token in [_ELSE,_OTHERWISE,_END]);
  248. if (token in [_ELSE,_OTHERWISE]) then
  249. begin
  250. if not try_to_consume(_ELSE) then
  251. consume(_OTHERWISE);
  252. casenode.addelseblock(statements_til_end);
  253. end
  254. else
  255. consume(_END);
  256. result:=casenode;
  257. end;
  258. function repeat_statement : tnode;
  259. var
  260. first,last,p_e : tnode;
  261. begin
  262. consume(_REPEAT);
  263. first:=nil;
  264. last:=nil;
  265. while token<>_UNTIL do
  266. begin
  267. if first=nil then
  268. begin
  269. last:=cstatementnode.create(statement,nil);
  270. first:=last;
  271. end
  272. else
  273. begin
  274. tstatementnode(last).right:=cstatementnode.create(statement,nil);
  275. last:=tstatementnode(last).right;
  276. end;
  277. if not try_to_consume(_SEMICOLON) then
  278. break;
  279. consume_emptystats;
  280. end;
  281. consume(_UNTIL);
  282. first:=cblocknode.create(first);
  283. p_e:=comp_expr([ef_accept_equal]);
  284. result:=cwhilerepeatnode.create(p_e,first,false,true);
  285. end;
  286. function while_statement : tnode;
  287. var
  288. p_e,p_a : tnode;
  289. begin
  290. consume(_WHILE);
  291. p_e:=comp_expr([ef_accept_equal]);
  292. consume(_DO);
  293. p_a:=statement;
  294. result:=cwhilerepeatnode.create(p_e,p_a,true,false);
  295. end;
  296. { a helper function which is used both by "with" and "for-in loop" nodes }
  297. function skip_nodes_before_load(p: tnode): tnode;
  298. begin
  299. { ignore nodes that don't add instructions in the tree }
  300. while assigned(p) and
  301. { equal type conversions }
  302. (
  303. (p.nodetype=typeconvn) and
  304. (ttypeconvnode(p).convtype=tc_equal)
  305. ) or
  306. { constant array index }
  307. (
  308. (p.nodetype=vecn) and
  309. (tvecnode(p).right.nodetype=ordconstn)
  310. ) do
  311. p:=tunarynode(p).left;
  312. result:=p;
  313. end;
  314. function for_statement : tnode;
  315. procedure check_range(hp:tnode; fordef: tdef);
  316. begin
  317. if (hp.nodetype=ordconstn) and
  318. (fordef.typ<>errordef) then
  319. adaptrange(fordef,tordconstnode(hp).value,false,false,true);
  320. end;
  321. function for_loop_create(hloopvar: tnode): tnode;
  322. var
  323. hp,
  324. hblock,
  325. hto,hfrom : tnode;
  326. backward : boolean;
  327. loopvarsym : tabstractvarsym;
  328. begin
  329. { Check loop variable }
  330. loopvarsym:=nil;
  331. { variable must be an ordinal, int64 is not allowed for 32bit targets }
  332. if (
  333. not(is_ordinal(hloopvar.resultdef))
  334. {$ifndef cpu64bitaddr}
  335. or is_64bitint(hloopvar.resultdef)
  336. {$endif not cpu64bitaddr}
  337. ) and
  338. (hloopvar.resultdef.typ<>undefineddef)
  339. then
  340. begin
  341. MessagePos(hloopvar.fileinfo,type_e_ordinal_expr_expected);
  342. hloopvar.resultdef:=generrordef;
  343. end;
  344. hp:=hloopvar;
  345. while assigned(hp) and
  346. (
  347. { record/object fields and array elements are allowed }
  348. { in tp7 mode only }
  349. (
  350. (m_tp7 in current_settings.modeswitches) and
  351. (
  352. ((hp.nodetype=subscriptn) and
  353. ((tsubscriptnode(hp).left.resultdef.typ=recorddef) or
  354. is_object(tsubscriptnode(hp).left.resultdef))
  355. ) or
  356. { constant array index }
  357. (
  358. (hp.nodetype=vecn) and
  359. is_constintnode(tvecnode(hp).right)
  360. )
  361. )
  362. ) or
  363. { equal typeconversions }
  364. (
  365. (hp.nodetype=typeconvn) and
  366. (ttypeconvnode(hp).convtype=tc_equal)
  367. )
  368. ) do
  369. begin
  370. { Use the recordfield for loopvarsym }
  371. if not assigned(loopvarsym) and
  372. (hp.nodetype=subscriptn) then
  373. loopvarsym:=tsubscriptnode(hp).vs;
  374. hp:=tunarynode(hp).left;
  375. end;
  376. if assigned(hp) and
  377. (hp.nodetype=loadn) then
  378. begin
  379. case tloadnode(hp).symtableentry.typ of
  380. staticvarsym,
  381. localvarsym,
  382. paravarsym :
  383. begin
  384. { we need a simple loadn:
  385. 1. The load must be in a global symtable or
  386. in the same level as the para of the current proc.
  387. 2. value variables (no const,out or var)
  388. 3. No threadvar, readonly or typedconst
  389. }
  390. if (
  391. (tloadnode(hp).symtable.symtablelevel=main_program_level) or
  392. (tloadnode(hp).symtable.symtablelevel=current_procinfo.procdef.parast.symtablelevel)
  393. ) and
  394. (tabstractvarsym(tloadnode(hp).symtableentry).varspez=vs_value) and
  395. ([vo_is_thread_var,vo_is_typed_const] * tabstractvarsym(tloadnode(hp).symtableentry).varoptions=[]) then
  396. begin
  397. { Assigning for-loop variable is only allowed in tp7 and macpas }
  398. if ([m_tp7,m_mac] * current_settings.modeswitches = []) then
  399. begin
  400. if not assigned(loopvarsym) then
  401. loopvarsym:=tabstractvarsym(tloadnode(hp).symtableentry);
  402. include(loopvarsym.varoptions,vo_is_loop_counter);
  403. end;
  404. end
  405. else
  406. begin
  407. { Typed const is allowed in tp7 }
  408. if not(m_tp7 in current_settings.modeswitches) or
  409. not(vo_is_typed_const in tabstractvarsym(tloadnode(hp).symtableentry).varoptions) then
  410. MessagePos(hp.fileinfo,type_e_illegal_count_var);
  411. end;
  412. end;
  413. else
  414. MessagePos(hp.fileinfo,type_e_illegal_count_var);
  415. end;
  416. end
  417. else
  418. MessagePos(hloopvar.fileinfo,type_e_illegal_count_var);
  419. hfrom:=comp_expr([ef_accept_equal]);
  420. if try_to_consume(_DOWNTO) then
  421. backward:=true
  422. else
  423. begin
  424. consume(_TO);
  425. backward:=false;
  426. end;
  427. hto:=comp_expr([ef_accept_equal]);
  428. consume(_DO);
  429. { Check if the constants fit in the range }
  430. check_range(hfrom,hloopvar.resultdef);
  431. check_range(hto,hloopvar.resultdef);
  432. { first set the varstate for from and to, so
  433. uses of loopvar in those expressions will also
  434. trigger a warning when it is not used yet. This
  435. needs to be done before the instruction block is
  436. parsed to have a valid hloopvar }
  437. typecheckpass(hfrom);
  438. set_varstate(hfrom,vs_read,[vsf_must_be_valid]);
  439. typecheckpass(hto);
  440. set_varstate(hto,vs_read,[vsf_must_be_valid]);
  441. typecheckpass(hloopvar);
  442. { in two steps, because vs_readwritten may turn on vsf_must_be_valid }
  443. { for some subnodes }
  444. set_varstate(hloopvar,vs_written,[]);
  445. set_varstate(hloopvar,vs_read,[vsf_must_be_valid]);
  446. { ... now the instruction block }
  447. hblock:=statement;
  448. { variable is not used for loop counter anymore }
  449. if assigned(loopvarsym) then
  450. exclude(loopvarsym.varoptions,vo_is_loop_counter);
  451. result:=cfornode.create(hloopvar,hfrom,hto,hblock,backward);
  452. { only in tp and mac pascal mode, we care about the value of the loop counter on loop exit
  453. I am not sure though, if this is the right rule, at least in delphi the loop counter is undefined
  454. on loop exit, we assume the same in all FPC modes }
  455. if ([m_objfpc,m_fpc,m_delphi]*current_settings.modeswitches)<>[] then
  456. Include(tfornode(Result).loopflags,lnf_dont_mind_loopvar_on_exit);
  457. end;
  458. function for_in_loop_create(hloopvar: tnode): tnode;
  459. var
  460. expr,hloopbody,hp: tnode;
  461. loopvarsym: tabstractvarsym;
  462. begin
  463. hp:=skip_nodes_before_load(hloopvar);
  464. if assigned(hp)and(hp.nodetype=loadn) then
  465. begin
  466. loopvarsym:=tabstractvarsym(tloadnode(hp).symtableentry);
  467. include(loopvarsym.varoptions,vo_is_loop_counter);
  468. end
  469. else
  470. loopvarsym:=nil;
  471. expr:=comp_expr([ef_accept_equal]);
  472. consume(_DO);
  473. set_varstate(hloopvar,vs_written,[]);
  474. set_varstate(hloopvar,vs_read,[vsf_must_be_valid]);
  475. hloopbody:=statement;
  476. if assigned(loopvarsym) then
  477. exclude(loopvarsym.varoptions,vo_is_loop_counter);
  478. result:=create_for_in_loop(hloopvar,hloopbody,expr);
  479. expr.free;
  480. end;
  481. var
  482. hloopvar: tnode;
  483. begin
  484. { parse loop header }
  485. consume(_FOR);
  486. hloopvar:=factor(false,[]);
  487. valid_for_loopvar(hloopvar,true);
  488. if try_to_consume(_ASSIGNMENT) then
  489. result:=for_loop_create(hloopvar)
  490. else if try_to_consume(_IN) then
  491. result:=for_in_loop_create(hloopvar)
  492. else
  493. begin
  494. consume(_ASSIGNMENT); // fail
  495. result:=cerrornode.create;
  496. end;
  497. end;
  498. function _with_statement : tnode;
  499. var
  500. p : tnode;
  501. i : longint;
  502. st : TSymtable;
  503. newblock : tblocknode;
  504. newstatement : tstatementnode;
  505. calltempnode,
  506. tempnode : ttempcreatenode;
  507. valuenode,
  508. hp,
  509. refnode : tnode;
  510. hdef : tdef;
  511. helperdef : tobjectdef;
  512. hasimplicitderef : boolean;
  513. withsymtablelist : TFPObjectList;
  514. procedure pushobjchild(withdef,obj:tobjectdef);
  515. var
  516. parenthelperdef : tobjectdef;
  517. begin
  518. if not assigned(obj) then
  519. exit;
  520. pushobjchild(withdef,obj.childof);
  521. { we need to look for helpers that were defined for the parent
  522. class as well }
  523. search_last_objectpascal_helper(obj,current_structdef,parenthelperdef);
  524. { push the symtables of the helper's parents in reverse order }
  525. if assigned(parenthelperdef) then
  526. pushobjchild(withdef,parenthelperdef.childof);
  527. { keep the original tobjectdef as owner, because that is used for
  528. visibility of the symtable }
  529. st:=twithsymtable.create(withdef,obj.symtable.SymList,refnode.getcopy);
  530. symtablestack.push(st);
  531. withsymtablelist.add(st);
  532. { push the symtable of the helper }
  533. if assigned(parenthelperdef) then
  534. begin
  535. st:=twithsymtable.create(withdef,parenthelperdef.symtable.SymList,refnode.getcopy);
  536. symtablestack.push(st);
  537. withsymtablelist.add(st);
  538. end;
  539. end;
  540. begin
  541. calltempnode:=nil;
  542. p:=comp_expr([ef_accept_equal]);
  543. do_typecheckpass(p);
  544. if (p.nodetype=vecn) and
  545. (nf_memseg in p.flags) then
  546. CGMessage(parser_e_no_with_for_variable_in_other_segments);
  547. { "with procvar" can never mean anything, so always try
  548. to call it in case it returns a record/object/... }
  549. maybe_call_procvar(p,false);
  550. if (p.resultdef.typ in [objectdef,recorddef,classrefdef]) or
  551. ((p.resultdef.typ=undefineddef) and (df_generic in current_procinfo.procdef.defoptions)) then
  552. begin
  553. newblock:=nil;
  554. valuenode:=nil;
  555. tempnode:=nil;
  556. hp:=skip_nodes_before_load(p);
  557. if (hp.nodetype=loadn) and
  558. (
  559. (tloadnode(hp).symtable=current_procinfo.procdef.localst) or
  560. (tloadnode(hp).symtable=current_procinfo.procdef.parast) or
  561. (tloadnode(hp).symtable.symtabletype in [staticsymtable,globalsymtable])
  562. ) and
  563. { MacPas objects are mapped to classes, and the MacPas compilers
  564. interpret with-statements with MacPas objects the same way
  565. as records (the object referenced by the with-statement
  566. must remain constant)
  567. }
  568. not(is_class(hp.resultdef) and
  569. (m_mac in current_settings.modeswitches)) then
  570. begin
  571. { simple load, we can reference direct }
  572. refnode:=p;
  573. end
  574. else
  575. begin
  576. { complex load, load in temp first }
  577. newblock:=internalstatements(newstatement);
  578. { when we can't take the address of p, load it in a temp }
  579. { since we may need its address later on }
  580. if not valid_for_addr(p,false) then
  581. begin
  582. calltempnode:=ctempcreatenode.create(p.resultdef,p.resultdef.size,tt_persistent,true);
  583. addstatement(newstatement,calltempnode);
  584. addstatement(newstatement,cassignmentnode.create(
  585. ctemprefnode.create(calltempnode),
  586. p));
  587. p:=ctemprefnode.create(calltempnode);
  588. typecheckpass(p);
  589. end;
  590. { several object types have implicit dereferencing }
  591. { is_implicit_pointer_object_type() returns true for records
  592. on the JVM target because they are implemented as classes
  593. there, but we definitely have to take their address here
  594. since otherwise a deep copy is made and changes are made to
  595. this copy rather than to the original one }
  596. hasimplicitderef:=
  597. (is_implicit_pointer_object_type(p.resultdef) or
  598. (p.resultdef.typ=classrefdef)) and
  599. not((target_info.system in systems_jvm) and
  600. ((p.resultdef.typ=recorddef) or
  601. is_object(p.resultdef)));
  602. if hasimplicitderef then
  603. hdef:=p.resultdef
  604. else
  605. hdef:=cpointerdef.create(p.resultdef);
  606. { load address of the value in a temp }
  607. tempnode:=ctempcreatenode.create_withnode(hdef,sizeof(pint),tt_persistent,true,p);
  608. typecheckpass(tnode(tempnode));
  609. valuenode:=p;
  610. refnode:=ctemprefnode.create(tempnode);
  611. fillchar(refnode.fileinfo,sizeof(tfileposinfo),0);
  612. { add address call for valuenode and deref for refnode if this
  613. is not done implicitly }
  614. if not hasimplicitderef then
  615. begin
  616. valuenode:=caddrnode.create_internal_nomark(valuenode);
  617. include(taddrnode(valuenode).addrnodeflags,anf_typedaddr);
  618. refnode:=cderefnode.create(refnode);
  619. fillchar(refnode.fileinfo,sizeof(tfileposinfo),0);
  620. end;
  621. addstatement(newstatement,tempnode);
  622. addstatement(newstatement,cassignmentnode.create(
  623. ctemprefnode.create(tempnode),
  624. valuenode));
  625. typecheckpass(refnode);
  626. end;
  627. { Note: the symtable of the helper is pushed after the following
  628. "case", the symtables of the helper's parents are passed in
  629. the "case" branches }
  630. withsymtablelist:=TFPObjectList.create(true);
  631. case p.resultdef.typ of
  632. objectdef :
  633. begin
  634. { do we have a helper for this type? }
  635. search_last_objectpascal_helper(tabstractrecorddef(p.resultdef),current_structdef,helperdef);
  636. { push symtables of all parents in reverse order }
  637. pushobjchild(tobjectdef(p.resultdef),tobjectdef(p.resultdef).childof);
  638. { push symtables of all parents of the helper in reverse order }
  639. if assigned(helperdef) then
  640. pushobjchild(helperdef,helperdef.childof);
  641. { push object symtable }
  642. st:=twithsymtable.Create(tobjectdef(p.resultdef),tobjectdef(p.resultdef).symtable.SymList,refnode);
  643. symtablestack.push(st);
  644. withsymtablelist.add(st);
  645. end;
  646. classrefdef :
  647. begin
  648. { do we have a helper for this type? }
  649. search_last_objectpascal_helper(tobjectdef(tclassrefdef(p.resultdef).pointeddef),current_structdef,helperdef);
  650. { push symtables of all parents in reverse order }
  651. pushobjchild(tobjectdef(tclassrefdef(p.resultdef).pointeddef),tobjectdef(tclassrefdef(p.resultdef).pointeddef).childof);
  652. { push symtables of all parents of the helper in reverse order }
  653. if assigned(helperdef) then
  654. pushobjchild(helperdef,helperdef.childof);
  655. { push object symtable }
  656. st:=twithsymtable.Create(tobjectdef(tclassrefdef(p.resultdef).pointeddef),tobjectdef(tclassrefdef(p.resultdef).pointeddef).symtable.SymList,refnode);
  657. symtablestack.push(st);
  658. withsymtablelist.add(st);
  659. end;
  660. recorddef :
  661. begin
  662. { do we have a helper for this type? }
  663. search_last_objectpascal_helper(tabstractrecorddef(p.resultdef),current_structdef,helperdef);
  664. { push symtables of all parents of the helper in reverse order }
  665. if assigned(helperdef) then
  666. pushobjchild(helperdef,helperdef.childof);
  667. { push record symtable }
  668. st:=twithsymtable.create(trecorddef(p.resultdef),trecorddef(p.resultdef).symtable.SymList,refnode);
  669. symtablestack.push(st);
  670. withsymtablelist.add(st);
  671. end;
  672. undefineddef :
  673. begin
  674. if not(df_generic in current_procinfo.procdef.defoptions) then
  675. internalerror(2012122802);
  676. helperdef:=nil;
  677. { push record symtable }
  678. st:=twithsymtable.create(p.resultdef,nil,refnode);
  679. symtablestack.push(st);
  680. withsymtablelist.add(st);
  681. end;
  682. else
  683. internalerror(200601271);
  684. end;
  685. { push helper symtable }
  686. if assigned(helperdef) then
  687. begin
  688. st:=twithsymtable.Create(helperdef,helperdef.symtable.SymList,refnode.getcopy);
  689. symtablestack.push(st);
  690. withsymtablelist.add(st);
  691. end;
  692. if try_to_consume(_COMMA) then
  693. p:=_with_statement()
  694. else
  695. begin
  696. consume(_DO);
  697. if token<>_SEMICOLON then
  698. p:=statement
  699. else
  700. p:=cnothingnode.create;
  701. end;
  702. { remove symtables in reverse order from the stack }
  703. for i:=withsymtablelist.count-1 downto 0 do
  704. symtablestack.pop(TSymtable(withsymtablelist[i]));
  705. withsymtablelist.free;
  706. { Finalize complex withnode with destroy of temp }
  707. if assigned(newblock) then
  708. begin
  709. addstatement(newstatement,p);
  710. if assigned(tempnode) then
  711. addstatement(newstatement,ctempdeletenode.create(tempnode));
  712. if assigned(calltempnode) then
  713. addstatement(newstatement,ctempdeletenode.create(calltempnode));
  714. p:=newblock;
  715. end;
  716. result:=p;
  717. end
  718. else
  719. begin
  720. p.free;
  721. Message1(parser_e_false_with_expr,p.resultdef.GetTypeName);
  722. { try to recover from error }
  723. if try_to_consume(_COMMA) then
  724. begin
  725. hp:=_with_statement();
  726. if (hp=nil) then; { remove warning about unused }
  727. end
  728. else
  729. begin
  730. consume(_DO);
  731. { ignore all }
  732. if token<>_SEMICOLON then
  733. statement;
  734. end;
  735. result:=nil;
  736. end;
  737. end;
  738. function with_statement : tnode;
  739. begin
  740. consume(_WITH);
  741. with_statement:=_with_statement();
  742. end;
  743. function raise_statement : tnode;
  744. var
  745. p,pobj,paddr,pframe : tnode;
  746. begin
  747. pobj:=nil;
  748. paddr:=nil;
  749. pframe:=nil;
  750. consume(_RAISE);
  751. if not(token in endtokens) then
  752. begin
  753. { object }
  754. pobj:=comp_expr([ef_accept_equal]);
  755. if try_to_consume(_AT) then
  756. begin
  757. paddr:=comp_expr([ef_accept_equal]);
  758. if try_to_consume(_COMMA) then
  759. pframe:=comp_expr([ef_accept_equal]);
  760. end;
  761. end
  762. else
  763. begin
  764. if (block_type<>bt_except) then
  765. Message(parser_e_no_reraise_possible);
  766. end;
  767. p:=craisenode.create(pobj,paddr,pframe);
  768. raise_statement:=p;
  769. end;
  770. function try_statement : tnode;
  771. procedure check_type_valid(var def: tdef);
  772. begin
  773. if not (is_class(def) or is_javaclass(def) or
  774. { skip showing error message the second time }
  775. (def.typ=errordef)) then
  776. begin
  777. Message1(type_e_class_type_expected,def.typename);
  778. def:=generrordef;
  779. end;
  780. end;
  781. var
  782. p_try_block,p_finally_block,first,last,
  783. p_default,p_specific,hp : tnode;
  784. ot : tDef;
  785. sym : tlocalvarsym;
  786. old_block_type : tblock_type;
  787. excepTSymtable : TSymtable;
  788. objname,objrealname : TIDString;
  789. srsym : tsym;
  790. srsymtable : TSymtable;
  791. t:ttoken;
  792. unit_found:boolean;
  793. oldcurrent_exceptblock: integer;
  794. filepostry : tfileposinfo;
  795. begin
  796. p_default:=nil;
  797. p_specific:=nil;
  798. excepTSymtable:=nil;
  799. last:=nil;
  800. { read statements to try }
  801. consume(_TRY);
  802. filepostry:=current_filepos;
  803. first:=nil;
  804. inc(exceptblockcounter);
  805. oldcurrent_exceptblock := current_exceptblock;
  806. current_exceptblock := exceptblockcounter;
  807. old_block_type := block_type;
  808. block_type := bt_body;
  809. while (token<>_FINALLY) and (token<>_EXCEPT) do
  810. begin
  811. if first=nil then
  812. begin
  813. last:=cstatementnode.create(statement,nil);
  814. first:=last;
  815. end
  816. else
  817. begin
  818. tstatementnode(last).right:=cstatementnode.create(statement,nil);
  819. last:=tstatementnode(last).right;
  820. end;
  821. if not try_to_consume(_SEMICOLON) then
  822. break;
  823. consume_emptystats;
  824. end;
  825. p_try_block:=cblocknode.create(first);
  826. if try_to_consume(_FINALLY) then
  827. begin
  828. inc(exceptblockcounter);
  829. current_exceptblock := exceptblockcounter;
  830. p_finally_block:=statements_til_end;
  831. try_statement:=ctryfinallynode.create(p_try_block,p_finally_block);
  832. try_statement.fileinfo:=filepostry;
  833. end
  834. else
  835. begin
  836. consume(_EXCEPT);
  837. block_type:=bt_except;
  838. inc(exceptblockcounter);
  839. current_exceptblock := exceptblockcounter;
  840. ot:=generrordef;
  841. p_specific:=nil;
  842. if (idtoken=_ON) then
  843. { catch specific exceptions }
  844. begin
  845. repeat
  846. consume(_ON);
  847. if token=_ID then
  848. begin
  849. objname:=pattern;
  850. objrealname:=orgpattern;
  851. { can't use consume_sym here, because we need already
  852. to check for the colon }
  853. searchsym(objname,srsym,srsymtable);
  854. consume(_ID);
  855. { is a explicit name for the exception given ? }
  856. if try_to_consume(_COLON) then
  857. begin
  858. single_type(ot,[]);
  859. check_type_valid(ot);
  860. sym:=clocalvarsym.create(objrealname,vs_value,ot,[]);
  861. end
  862. else
  863. begin
  864. { check if type is valid, must be done here because
  865. with "e: Exception" the e is not necessary }
  866. { support unit.identifier }
  867. unit_found:=try_consume_unitsym_no_specialize(srsym,srsymtable,t,[],objname);
  868. if srsym=nil then
  869. begin
  870. identifier_not_found(orgpattern);
  871. srsym:=generrorsym;
  872. end;
  873. if unit_found then
  874. consume(t);
  875. { check if type is valid, must be done here because
  876. with "e: Exception" the e is not necessary }
  877. if (srsym.typ=typesym) then
  878. begin
  879. ot:=ttypesym(srsym).typedef;
  880. parse_nested_types(ot,false,false,nil);
  881. check_type_valid(ot);
  882. end
  883. else
  884. begin
  885. Message(type_e_type_id_expected);
  886. ot:=generrordef;
  887. end;
  888. { create dummy symbol so we don't need a special
  889. case in ncgflw, and so that we always know the
  890. type }
  891. sym:=clocalvarsym.create('$exceptsym',vs_value,ot,[]);
  892. end;
  893. excepTSymtable:=tstt_excepTSymtable.create;
  894. excepTSymtable.insert(sym);
  895. symtablestack.push(excepTSymtable);
  896. end
  897. else
  898. consume(_ID);
  899. consume(_DO);
  900. hp:=connode.create(nil,statement);
  901. if ot.typ=errordef then
  902. begin
  903. hp.free;
  904. hp:=cerrornode.create;
  905. end;
  906. if p_specific=nil then
  907. begin
  908. last:=hp;
  909. p_specific:=last;
  910. end
  911. else
  912. begin
  913. tonnode(last).left:=hp;
  914. last:=tonnode(last).left;
  915. end;
  916. { set the informations }
  917. { only if the creation of the onnode was succesful, it's possible }
  918. { that last and hp are errornodes (JM) }
  919. if last.nodetype = onn then
  920. begin
  921. tonnode(last).excepttype:=tobjectdef(ot);
  922. tonnode(last).excepTSymtable:=excepTSymtable;
  923. end;
  924. { remove exception symtable }
  925. if assigned(excepTSymtable) then
  926. begin
  927. symtablestack.pop(excepTSymtable);
  928. if last.nodetype <> onn then
  929. excepTSymtable.free;
  930. end;
  931. if not try_to_consume(_SEMICOLON) then
  932. break;
  933. consume_emptystats;
  934. until (token in [_END,_ELSE]);
  935. if try_to_consume(_ELSE) then
  936. begin
  937. { catch the other exceptions }
  938. p_default:=statements_til_end;
  939. end
  940. else
  941. consume(_END);
  942. end
  943. else
  944. begin
  945. { catch all exceptions }
  946. p_default:=statements_til_end;
  947. end;
  948. try_statement:=ctryexceptnode.create(p_try_block,p_specific,p_default);
  949. end;
  950. block_type:=old_block_type;
  951. current_exceptblock := oldcurrent_exceptblock;
  952. end;
  953. function _asm_statement : tnode;
  954. var
  955. asmstat : tasmnode;
  956. reg : tregister;
  957. asmreader : tbaseasmreader;
  958. entrypos : tfileposinfo;
  959. hl : TAsmList;
  960. begin
  961. Inside_asm_statement:=true;
  962. asmstat:=nil;
  963. hl:=nil;
  964. if assigned(asmmodeinfos[current_settings.asmmode]) then
  965. begin
  966. asmreader:=asmmodeinfos[current_settings.asmmode]^.casmreader.create;
  967. entrypos:=current_filepos;
  968. hl:=asmreader.assemble as TAsmList;
  969. if (not hl.empty) then
  970. begin
  971. { mark boundaries of assembler block, this is necessary for optimizer }
  972. hl.insert(tai_marker.create(mark_asmblockstart));
  973. hl.concat(tai_marker.create(mark_asmblockend));
  974. end;
  975. asmstat:=casmnode.create(hl);
  976. asmstat.fileinfo:=entrypos;
  977. asmreader.free;
  978. end
  979. else
  980. Message(parser_f_assembler_reader_not_supported);
  981. { Mark procedure that it has assembler blocks }
  982. include(current_procinfo.flags,pi_has_assembler_block);
  983. { Read first the _ASM statement }
  984. consume(_ASM);
  985. { Force an empty register list for pure assembler routines,
  986. so that pass2 won't allocate volatile registers for them. }
  987. asmstat.has_registerlist:=(po_assembler in current_procinfo.procdef.procoptions);
  988. { END is read, got a list of changed registers? }
  989. if try_to_consume(_LECKKLAMMER) then
  990. begin
  991. if token<>_RECKKLAMMER then
  992. begin
  993. if po_assembler in current_procinfo.procdef.procoptions then
  994. Message(parser_w_register_list_ignored);
  995. repeat
  996. { it's possible to specify the modified registers }
  997. reg:=std_regnum_search(lower(cstringpattern));
  998. if reg<>NR_NO then
  999. begin
  1000. if not(po_assembler in current_procinfo.procdef.procoptions) and assigned(hl) then
  1001. begin
  1002. hl.Insert(tai_regalloc.alloc(reg,nil));
  1003. hl.Insert(tai_regalloc.markused(reg));
  1004. hl.Concat(tai_regalloc.dealloc(reg,nil));
  1005. end;
  1006. end
  1007. else
  1008. Message(asmr_e_invalid_register);
  1009. consume(_CSTRING);
  1010. if not try_to_consume(_COMMA) then
  1011. break;
  1012. until false;
  1013. asmstat.has_registerlist:=true;
  1014. end;
  1015. consume(_RECKKLAMMER);
  1016. end;
  1017. Inside_asm_statement:=false;
  1018. _asm_statement:=asmstat;
  1019. end;
  1020. function statement : tnode;
  1021. var
  1022. p,
  1023. code : tnode;
  1024. filepos : tfileposinfo;
  1025. srsym : tsym;
  1026. srsymtable : TSymtable;
  1027. s : TIDString;
  1028. begin
  1029. filepos:=current_tokenpos;
  1030. code:=nil;
  1031. case token of
  1032. _GOTO :
  1033. begin
  1034. if not(cs_support_goto in current_settings.moduleswitches) then
  1035. Message(sym_e_goto_and_label_not_supported);
  1036. consume(_GOTO);
  1037. if (token<>_INTCONST) and (token<>_ID) then
  1038. begin
  1039. Message(sym_e_label_not_found);
  1040. code:=cerrornode.create;
  1041. end
  1042. else
  1043. begin
  1044. if token=_ID then
  1045. consume_sym(srsym,srsymtable)
  1046. else
  1047. begin
  1048. if token<>_INTCONST then
  1049. internalerror(201008021);
  1050. { strip leading 0's in iso mode }
  1051. if (([m_iso,m_extpas]*current_settings.modeswitches)<>[]) then
  1052. while pattern[1]='0' do
  1053. delete(pattern,1,1);
  1054. searchsym(pattern,srsym,srsymtable);
  1055. if srsym=nil then
  1056. begin
  1057. identifier_not_found(pattern);
  1058. srsym:=generrorsym;
  1059. srsymtable:=nil;
  1060. end;
  1061. consume(token);
  1062. end;
  1063. if srsym.typ<>labelsym then
  1064. begin
  1065. Message(sym_e_id_is_no_label_id);
  1066. code:=cerrornode.create;
  1067. end
  1068. else
  1069. begin
  1070. { goto outside the current scope? }
  1071. if srsym.owner<>current_procinfo.procdef.localst then
  1072. begin
  1073. { allowed? }
  1074. if not(m_non_local_goto in current_settings.modeswitches) then
  1075. Message(parser_e_goto_outside_proc);
  1076. include(current_procinfo.flags,pi_has_global_goto);
  1077. end;
  1078. code:=cgotonode.create(tlabelsym(srsym));
  1079. tgotonode(code).labelsym:=tlabelsym(srsym);
  1080. { set flag that this label is used }
  1081. tlabelsym(srsym).used:=true;
  1082. end;
  1083. end;
  1084. end;
  1085. _BEGIN :
  1086. code:=statement_block(_BEGIN);
  1087. _IF :
  1088. code:=if_statement;
  1089. _CASE :
  1090. code:=case_statement;
  1091. _REPEAT :
  1092. code:=repeat_statement;
  1093. _WHILE :
  1094. code:=while_statement;
  1095. _FOR :
  1096. code:=for_statement;
  1097. _WITH :
  1098. code:=with_statement;
  1099. _TRY :
  1100. code:=try_statement;
  1101. _RAISE :
  1102. code:=raise_statement;
  1103. { semicolons,else until and end are ignored }
  1104. _SEMICOLON,
  1105. _ELSE,
  1106. _UNTIL,
  1107. _END:
  1108. code:=cnothingnode.create;
  1109. _FAIL :
  1110. begin
  1111. if (current_procinfo.procdef.proctypeoption<>potype_constructor) then
  1112. Message(parser_e_fail_only_in_constructor);
  1113. consume(_FAIL);
  1114. code:=cnodeutils.call_fail_node;
  1115. end;
  1116. _ASM :
  1117. begin
  1118. if parse_generic then
  1119. Message(parser_e_no_assembler_in_generic);
  1120. code:=_asm_statement;
  1121. end;
  1122. _PLUS:
  1123. begin
  1124. Message(parser_e_syntax_error);
  1125. consume(_PLUS);
  1126. end;
  1127. _EOF :
  1128. Message(scan_f_end_of_file);
  1129. else
  1130. begin
  1131. { don't typecheck yet, because that will also simplify, which may
  1132. result in not detecting certain kinds of syntax errors --
  1133. see mantis #15594 }
  1134. p:=expr(false);
  1135. { save the pattern here for latter usage, the label could be "000",
  1136. even if we read an expression, the pattern is still valid if it's really
  1137. a label (FK)
  1138. if you want to mess here, take care of
  1139. tests/webtbs/tw3546.pp
  1140. }
  1141. s:=pattern;
  1142. { When a colon follows a intconst then transform it into a label }
  1143. if (p.nodetype=ordconstn) and
  1144. try_to_consume(_COLON) then
  1145. begin
  1146. { in iso mode, 0003: is equal to 3: }
  1147. if (([m_iso,m_extpas]*current_settings.modeswitches)<>[]) then
  1148. searchsym(tostr(tordconstnode(p).value),srsym,srsymtable)
  1149. else
  1150. searchsym(s,srsym,srsymtable);
  1151. p.free;
  1152. if assigned(srsym) and
  1153. (srsym.typ=labelsym) then
  1154. begin
  1155. if tlabelsym(srsym).defined then
  1156. Message(sym_e_label_already_defined);
  1157. if symtablestack.top.symtablelevel<>srsymtable.symtablelevel then
  1158. begin
  1159. tlabelsym(srsym).nonlocal:=true;
  1160. include(current_procinfo.flags,pi_has_interproclabel);
  1161. end;
  1162. if tlabelsym(srsym).nonlocal and
  1163. (current_procinfo.procdef.proctypeoption in [potype_unitinit,potype_unitfinalize]) then
  1164. Message(sym_e_interprocgoto_into_init_final_code_not_allowed);
  1165. tlabelsym(srsym).defined:=true;
  1166. p:=clabelnode.create(nil,tlabelsym(srsym));
  1167. tlabelsym(srsym).code:=p;
  1168. end
  1169. else
  1170. begin
  1171. Message1(sym_e_label_used_and_not_defined,s);
  1172. p:=cnothingnode.create;
  1173. end;
  1174. end;
  1175. if p.nodetype=labeln then
  1176. begin
  1177. { the pointer to the following instruction }
  1178. { isn't a very clean way }
  1179. if token in endtokens then
  1180. tlabelnode(p).left:=cnothingnode.create
  1181. else
  1182. tlabelnode(p).left:=statement();
  1183. { be sure to have left also typecheckpass }
  1184. typecheckpass(tlabelnode(p).left);
  1185. end
  1186. else
  1187. { change a load of a procvar to a call. this is also
  1188. supported in fpc mode }
  1189. if p.nodetype in [vecn,derefn,typeconvn,subscriptn,loadn] then
  1190. maybe_call_procvar(p,false);
  1191. { blockn support because a read/write is changed into a blocknode
  1192. with a separate statement for each read/write operation (JM)
  1193. the same is true for val() if the third parameter is not 32 bit
  1194. goto nodes are created by the compiler for non local exit statements, so
  1195. include them as well
  1196. }
  1197. if not(p.nodetype in [nothingn,errorn,calln,ifn,assignn,breakn,inlinen,
  1198. continuen,labeln,blockn,exitn,goton]) or
  1199. ((p.nodetype=inlinen) and
  1200. not is_void(p.resultdef)) or
  1201. ((p.nodetype=calln) and
  1202. (assigned(tcallnode(p).procdefinition)) and
  1203. (tcallnode(p).procdefinition.proctypeoption=potype_operator)) then
  1204. Message(parser_e_illegal_expression);
  1205. if not assigned(p.resultdef) then
  1206. do_typecheckpass(p);
  1207. { Specify that we don't use the value returned by the call.
  1208. This is used for :
  1209. - dispose of temp stack space
  1210. - dispose on FPU stack
  1211. - extended syntax checking }
  1212. if (p.nodetype=calln) then
  1213. begin
  1214. exclude(tcallnode(p).callnodeflags,cnf_return_value_used);
  1215. { in $x- state, the function result must not be ignored }
  1216. if not(cs_extsyntax in current_settings.moduleswitches) and
  1217. not(is_void(p.resultdef)) and
  1218. { can be nil in case there was an error in the expression }
  1219. assigned(tcallnode(p).procdefinition) and
  1220. { allow constructor calls to drop the result if they are
  1221. called as instance methods instead of class methods }
  1222. not(
  1223. (tcallnode(p).procdefinition.proctypeoption=potype_constructor) and
  1224. is_class_or_object(tprocdef(tcallnode(p).procdefinition).struct) and
  1225. assigned(tcallnode(p).methodpointer) and
  1226. (tnode(tcallnode(p).methodpointer).resultdef.typ=objectdef)
  1227. ) then
  1228. Message(parser_e_illegal_expression);
  1229. end;
  1230. code:=p;
  1231. end;
  1232. end;
  1233. if assigned(code) then
  1234. begin
  1235. typecheckpass(code);
  1236. code.fileinfo:=filepos;
  1237. end;
  1238. statement:=code;
  1239. end;
  1240. function statement_block(starttoken : ttoken) : tnode;
  1241. var
  1242. first,last : tnode;
  1243. filepos : tfileposinfo;
  1244. begin
  1245. first:=nil;
  1246. last:=nil;
  1247. filepos:=current_tokenpos;
  1248. consume(starttoken);
  1249. while not((token=_END) or (token=_FINALIZATION)) do
  1250. begin
  1251. if first=nil then
  1252. begin
  1253. last:=cstatementnode.create(statement,nil);
  1254. first:=last;
  1255. end
  1256. else
  1257. begin
  1258. tstatementnode(last).right:=cstatementnode.create(statement,nil);
  1259. last:=tstatementnode(last).right;
  1260. end;
  1261. if ((token=_END) or (token=_FINALIZATION)) then
  1262. break
  1263. else
  1264. begin
  1265. { if no semicolon, then error and go on }
  1266. if token<>_SEMICOLON then
  1267. begin
  1268. consume(_SEMICOLON);
  1269. consume_all_until(_SEMICOLON);
  1270. end;
  1271. consume(_SEMICOLON);
  1272. end;
  1273. consume_emptystats;
  1274. end;
  1275. { don't consume the finalization token, it is consumed when
  1276. reading the finalization block, but allow it only after
  1277. an initalization ! }
  1278. if (starttoken<>_INITIALIZATION) or (token<>_FINALIZATION) then
  1279. consume(_END);
  1280. last:=cblocknode.create(first);
  1281. last.fileinfo:=filepos;
  1282. statement_block:=last;
  1283. end;
  1284. function assembler_block : tnode;
  1285. var
  1286. p : tnode;
  1287. {$if not(defined(sparcgen)) and not(defined(arm)) and not(defined(avr)) and not(defined(mips))}
  1288. locals : longint;
  1289. {$endif not(defined(sparcgen)) and not(defined(arm)) and not(defined(avr)) and not(defined(mips))}
  1290. srsym : tsym;
  1291. begin
  1292. if parse_generic then
  1293. message(parser_e_no_assembler_in_generic);
  1294. { Rename the funcret so that recursive calls are possible }
  1295. if not is_void(current_procinfo.procdef.returndef) then
  1296. begin
  1297. srsym:=TSym(current_procinfo.procdef.localst.Find(current_procinfo.procdef.procsym.name));
  1298. if assigned(srsym) then
  1299. srsym.realname:='$hiddenresult';
  1300. end;
  1301. { delphi uses register calling for assembler methods }
  1302. if (m_delphi in current_settings.modeswitches) and
  1303. (po_assembler in current_procinfo.procdef.procoptions) and
  1304. not(po_hascallingconvention in current_procinfo.procdef.procoptions) then
  1305. current_procinfo.procdef.proccalloption:=pocall_register;
  1306. { force the asm statement }
  1307. if token<>_ASM then
  1308. consume(_ASM);
  1309. include(current_procinfo.flags,pi_is_assembler);
  1310. p:=_asm_statement;
  1311. {$if not(defined(sparcgen)) and not(defined(arm)) and not(defined(avr)) and not(defined(mips))}
  1312. if (po_assembler in current_procinfo.procdef.procoptions) then
  1313. begin
  1314. { set the framepointer to esp for assembler functions when the
  1315. following conditions are met:
  1316. - if the are no local variables and parameters (except the allocated result)
  1317. - no reference to the result variable (refcount<=1)
  1318. - result is not stored as parameter
  1319. - target processor has optional frame pointer save
  1320. (vm, i386, vm only currently)
  1321. }
  1322. locals:=tabstractlocalsymtable(current_procinfo.procdef.parast).count_locals;
  1323. if (current_procinfo.procdef.localst.symtabletype=localsymtable) then
  1324. inc(locals,tabstractlocalsymtable(current_procinfo.procdef.localst).count_locals);
  1325. if (locals=0) and
  1326. not (current_procinfo.procdef.owner.symtabletype in [ObjectSymtable,recordsymtable]) and
  1327. (not assigned(current_procinfo.procdef.funcretsym) or
  1328. (tabstractvarsym(current_procinfo.procdef.funcretsym).refs<=1)) and
  1329. not (df_generic in current_procinfo.procdef.defoptions) and
  1330. not(paramanager.ret_in_param(current_procinfo.procdef.returndef,current_procinfo.procdef)) then
  1331. begin
  1332. { Only need to set the framepointer, the locals will
  1333. be inserted with the correct reference in tcgasmnode.pass_generate_code }
  1334. current_procinfo.framepointer:=NR_STACK_POINTER_REG;
  1335. end;
  1336. end;
  1337. {$endif not(defined(sparcgen)) and not(defined(arm)) and not(defined(avr)) not(defined(mipsel))}
  1338. { Flag the result as assigned when it is returned in a
  1339. register.
  1340. }
  1341. if assigned(current_procinfo.procdef.funcretsym) and
  1342. not (df_generic in current_procinfo.procdef.defoptions) and
  1343. (not paramanager.ret_in_param(current_procinfo.procdef.returndef,current_procinfo.procdef)) then
  1344. tabstractvarsym(current_procinfo.procdef.funcretsym).varstate:=vs_initialised;
  1345. { because the END is already read we need to get the
  1346. last_endtoken_filepos here (PFV) }
  1347. last_endtoken_filepos:=current_tokenpos;
  1348. assembler_block:=p;
  1349. end;
  1350. end.