nset.pas 43 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375
  1. {
  2. Copyright (c) 2000-2002 by Florian Klaempfl
  3. Type checking and register allocation for set/case nodes
  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 nset;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. cclasses,constexp,
  22. node,globtype,globals,
  23. aasmbase,ncon,nflw,symtype;
  24. type
  25. TLabelType = (ltOrdinal, ltConstString);
  26. pcaselabel = ^tcaselabel;
  27. tcaselabel = record
  28. { unique blockid }
  29. blockid : longint;
  30. { left and right tree node }
  31. less,
  32. greater : pcaselabel;
  33. labellabel : TAsmLabel;
  34. { range type }
  35. case label_type : TLabelType of
  36. ltOrdinal:
  37. (
  38. _low,
  39. _high : TConstExprInt;
  40. );
  41. ltConstString:
  42. (
  43. _low_str,
  44. _high_str : tstringconstnode;
  45. );
  46. end;
  47. pcaseblock = ^tcaseblock;
  48. tcaseblock = record
  49. { label (only used in pass_generate_code) }
  50. blocklabel : tasmlabel;
  51. { shortcut - set to true if blocklabel isn't actually unique to the
  52. case block due to one of the following conditions:
  53. - if the node contains a jump, then the label is set to that jump's destination,
  54. - if the node is empty, the label is set to the end label. }
  55. shortcut: Boolean;
  56. statementlabel : tlabelnode;
  57. { instructions }
  58. statement : tnode;
  59. end;
  60. tsetelementnode = class(tbinarynode)
  61. constructor create(l,r : tnode);virtual;
  62. function pass_typecheck:tnode;override;
  63. function pass_1 : tnode;override;
  64. end;
  65. tsetelementnodeclass = class of tsetelementnode;
  66. tinnode = class(tbinopnode)
  67. constructor create(l,r : tnode);virtual;reintroduce;
  68. function pass_typecheck:tnode;override;
  69. function simplify(forinline : boolean):tnode;override;
  70. function pass_1 : tnode;override;
  71. end;
  72. tinnodeclass = class of tinnode;
  73. trangenode = class(tbinarynode)
  74. constructor create(l,r : tnode);virtual;
  75. function pass_typecheck:tnode;override;
  76. function pass_1 : tnode;override;
  77. end;
  78. trangenodeclass = class of trangenode;
  79. tcasenode = class(tunarynode)
  80. strict private
  81. { Number of labels }
  82. flabelcnt: cardinal;
  83. { Number of individual values checked, counting each value in a range
  84. individually (e.g. 0..2 counts as 3). }
  85. flabelcoverage: qword;
  86. fcountsuptodate: boolean;
  87. function getlabelcnt: cardinal;
  88. function getlabelcoverage: qword;
  89. procedure updatecoverage;
  90. procedure checkordinalcoverage;
  91. public
  92. blocks : TFPList;
  93. elseblock : tnode;
  94. constructor create(l:tnode);virtual;
  95. destructor destroy;override;
  96. constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
  97. procedure ppuwrite(ppufile:tcompilerppufile);override;
  98. procedure buildderefimpl;override;
  99. procedure derefimpl;override;
  100. function dogetcopy : tnode;override;
  101. procedure printnodetree(var t:text);override;
  102. {$ifdef DEBUG_NODE_XML}
  103. procedure XMLPrintNodeTree(var t:text); override;
  104. {$endif DEBUG_NODE_XML}
  105. procedure insertintolist(l : tnodelist);override;
  106. function pass_typecheck:tnode;override;
  107. function pass_1 : tnode;override;
  108. function simplify(forinline:boolean):tnode;override;
  109. function docompare(p: tnode): boolean; override;
  110. procedure addlabel(blockid:longint;const l,h : TConstExprInt); overload;
  111. procedure addlabel(blockid:longint;l,h : tstringconstnode); overload;
  112. procedure addblock(blockid:longint;instr:tnode);
  113. procedure addelseblock(instr:tnode);
  114. property labelcnt: cardinal read getlabelcnt;
  115. { returns one less than the covered case range, so that it
  116. does not overflow for a fully covered qword range }
  117. property labelcoverage: qword read getlabelcoverage;
  118. protected
  119. flabels : pcaselabel;
  120. public
  121. property labels: pcaselabel read flabels;
  122. end;
  123. tcasenodeclass = class of tcasenode;
  124. var
  125. csetelementnode : tsetelementnodeclass = tsetelementnode;
  126. cinnode : tinnodeclass = tinnode;
  127. crangenode : trangenodeclass = trangenode;
  128. ccasenode : tcasenodeclass = tcasenode;
  129. { searches the highest label }
  130. function case_get_max(root : pcaselabel) : tconstexprint;
  131. { searches the lowest label }
  132. function case_get_min(root : pcaselabel) : tconstexprint;
  133. implementation
  134. uses
  135. verbose,cutils,
  136. symconst,symdef,symsym,symtable,defutil,defcmp,
  137. htypechk,pass_1,
  138. nadd,nbas,ncal,ncnv,nld,nutils,
  139. cgbase;
  140. {*****************************************************************************
  141. TSETELEMENTNODE
  142. *****************************************************************************}
  143. constructor tsetelementnode.create(l,r : tnode);
  144. begin
  145. inherited create(setelementn,l,r);
  146. end;
  147. function tsetelementnode.pass_typecheck:tnode;
  148. begin
  149. result:=nil;
  150. typecheckpass(left);
  151. if assigned(right) then
  152. typecheckpass(right);
  153. set_varstate(left,vs_read,[vsf_must_be_valid]);
  154. if codegenerror then
  155. exit;
  156. resultdef:=left.resultdef;
  157. end;
  158. function tsetelementnode.pass_1 : tnode;
  159. begin
  160. result:=nil;
  161. firstpass(left);
  162. if assigned(right) then
  163. firstpass(right);
  164. if codegenerror then
  165. exit;
  166. expectloc:=left.expectloc;
  167. end;
  168. {*****************************************************************************
  169. TINNODE
  170. *****************************************************************************}
  171. constructor tinnode.create(l,r : tnode);
  172. begin
  173. inherited create(inn,l,r);
  174. end;
  175. function tinnode.pass_typecheck:tnode;
  176. var
  177. t : tnode;
  178. function createsetconst(psd : tsetdef) : pconstset;
  179. var
  180. pcs : pconstset;
  181. i : longint;
  182. begin
  183. new(pcs);
  184. case psd.elementdef.typ of
  185. enumdef :
  186. begin
  187. for i := 0 to tenumdef(psd.elementdef).symtable.SymList.Count - 1 do
  188. begin
  189. include(pcs^,tenumsym(tenumdef(psd.elementdef).symtable.SymList[i]).value);
  190. end;
  191. end;
  192. orddef :
  193. begin
  194. for i:=int64(torddef(psd.elementdef).low) to int64(torddef(psd.elementdef).high) do
  195. include(pcs^,i);
  196. end;
  197. else
  198. internalerror(2019050516);
  199. end;
  200. createsetconst:=pcs;
  201. end;
  202. begin
  203. result:=nil;
  204. resultdef:=pasbool1type;
  205. typecheckpass(right);
  206. set_varstate(right,vs_read,[vsf_must_be_valid]);
  207. if codegenerror then
  208. exit;
  209. { Convert array constructor first to set }
  210. if is_array_constructor(right.resultdef) then
  211. begin
  212. arrayconstructor_to_set(right);
  213. firstpass(right);
  214. if codegenerror then
  215. exit;
  216. end;
  217. typecheckpass(left);
  218. set_varstate(left,vs_read,[vsf_must_be_valid]);
  219. if codegenerror then
  220. exit;
  221. if not assigned(left.resultdef) then
  222. internalerror(20021126);
  223. t:=self;
  224. if isbinaryoverloaded(t,[]) then
  225. begin
  226. result:=t;
  227. exit;
  228. end;
  229. if right.resultdef.typ<>setdef then
  230. CGMessage(sym_e_set_expected);
  231. if codegenerror then
  232. exit;
  233. if (m_tp7 in current_settings.modeswitches) then
  234. begin
  235. { insert a hint that a range check error might occur on non-byte
  236. elements with the in operator.
  237. }
  238. if (
  239. (left.resultdef.typ = orddef) and not
  240. (torddef(left.resultdef).ordtype in [s8bit,u8bit,uchar,pasbool1,pasbool8,bool8bit])
  241. )
  242. or
  243. (
  244. (left.resultdef.typ = enumdef) and
  245. (tenumdef(left.resultdef).maxval > 255)
  246. )
  247. then
  248. CGMessage(type_h_in_range_check);
  249. { type conversion/check }
  250. if assigned(tsetdef(right.resultdef).elementdef) then
  251. inserttypeconv(left,tsetdef(right.resultdef).elementdef);
  252. end
  253. else if not is_ordinal(left.resultdef) or (left.resultdef.size > u32inttype.size) then
  254. begin
  255. CGMessage(type_h_in_range_check);
  256. if is_signed(left.resultdef) then
  257. inserttypeconv(left,s32inttype)
  258. else
  259. inserttypeconv(left,u32inttype);
  260. end
  261. else if assigned(tsetdef(right.resultdef).elementdef) and
  262. not(is_integer(tsetdef(right.resultdef).elementdef) and
  263. is_integer(left.resultdef)) then
  264. { Type conversion to check things like 'char in set_of_byte'. }
  265. { Can't use is_subequal because that will fail for }
  266. { 'widechar in set_of_char' }
  267. { Can't use the type conversion for integers because then }
  268. { "longint in set_of_byte" will give a range check error }
  269. { instead of false }
  270. inserttypeconv(left,tsetdef(right.resultdef).elementdef);
  271. { empty set then return false }
  272. if not assigned(tsetdef(right.resultdef).elementdef) or
  273. ((right.nodetype = setconstn) and
  274. (tnormalset(tsetconstnode(right).value_set^) = [])) then
  275. begin
  276. t:=cordconstnode.create(0,pasbool1type,false);
  277. typecheckpass(t);
  278. result:=t;
  279. exit;
  280. end;
  281. result:=simplify(false);
  282. end;
  283. function tinnode.simplify(forinline : boolean):tnode;
  284. var
  285. t : tnode;
  286. begin
  287. result:=nil;
  288. { constant evaluation }
  289. if (left.nodetype=ordconstn) then
  290. begin
  291. if (right.nodetype=setconstn) then
  292. begin
  293. { tordconstnode.value is int64 -> signed -> the expression }
  294. { below will be converted to longint on 32 bit systems due }
  295. { to the rule above -> will give range check error if }
  296. { value > high(longint) if we don't take the signedness }
  297. { into account }
  298. if Tordconstnode(left).value.signed then
  299. t:=cordconstnode.create(byte(tordconstnode(left).value.svalue in Tsetconstnode(right).value_set^),
  300. pasbool1type,true)
  301. else
  302. t:=cordconstnode.create(byte(tordconstnode(left).value.uvalue in Tsetconstnode(right).value_set^),
  303. pasbool1type,true);
  304. typecheckpass(t);
  305. result:=t;
  306. exit;
  307. end
  308. else
  309. begin
  310. if (Tordconstnode(left).value<int64(tsetdef(right.resultdef).setbase)) or
  311. (Tordconstnode(left).value>int64(Tsetdef(right.resultdef).setmax)) then
  312. begin
  313. t:=cordconstnode.create(0, pasbool1type, true);
  314. typecheckpass(t);
  315. result:=t;
  316. exit;
  317. end;
  318. end;
  319. end;
  320. end;
  321. function tinnode.pass_1 : tnode;
  322. begin
  323. result:=nil;
  324. expectloc:=LOC_REGISTER;
  325. firstpass(right);
  326. firstpass(left);
  327. if codegenerror then
  328. exit;
  329. end;
  330. {*****************************************************************************
  331. TRANGENODE
  332. *****************************************************************************}
  333. constructor trangenode.create(l,r : tnode);
  334. var
  335. value: string;
  336. begin
  337. { if right is char and left is string then }
  338. { right should be treated as one-symbol string }
  339. if is_conststringnode(l) and is_constcharnode(r) then
  340. begin
  341. value := char(tordconstnode(r).value.uvalue) + ''#0;
  342. r.free;
  343. r := cstringconstnode.createstr(value);
  344. do_typecheckpass(r);
  345. end;
  346. inherited create(rangen,l,r);
  347. end;
  348. function trangenode.pass_typecheck : tnode;
  349. begin
  350. result:=nil;
  351. typecheckpass(left);
  352. typecheckpass(right);
  353. set_varstate(left,vs_read,[vsf_must_be_valid]);
  354. set_varstate(right,vs_read,[vsf_must_be_valid]);
  355. if codegenerror then
  356. exit;
  357. { both types must be compatible }
  358. if compare_defs(left.resultdef,right.resultdef,left.nodetype)=te_incompatible then
  359. IncompatibleTypes(left.resultdef,right.resultdef);
  360. { check if only when its a constant set and
  361. ignore range nodes which are generic parameter derived }
  362. if not (nf_generic_para in flags) and (left.nodetype=ordconstn) and (right.nodetype=ordconstn) then
  363. begin
  364. { upper limit must be greater or equal than lower limit }
  365. if (tordconstnode(left).value>tordconstnode(right).value) and
  366. ((tordconstnode(left).value<0) or (tordconstnode(right).value>=0)) then
  367. CGMessage(parser_e_upper_lower_than_lower);
  368. end;
  369. resultdef:=left.resultdef;
  370. end;
  371. function trangenode.pass_1 : tnode;
  372. begin
  373. result:=nil;
  374. firstpass(left);
  375. firstpass(right);
  376. if codegenerror then
  377. exit;
  378. expectloc:=left.expectloc;
  379. end;
  380. {*****************************************************************************
  381. Case Helpers
  382. *****************************************************************************}
  383. { labels is the number of case-labels, while cases includes each individual
  384. value in a range (e.g. "0..2" counts as 3) }
  385. procedure case_count_labels(root : pcaselabel; out labels, cases: longint);
  386. procedure count(p : pcaselabel);
  387. begin
  388. inc(labels);
  389. inc(cases, (p^._high.svalue - p^._low.svalue) + 1);
  390. if assigned(p^.less) then
  391. count(p^.less);
  392. if assigned(p^.greater) then
  393. count(p^.greater);
  394. end;
  395. begin
  396. labels:=0;
  397. cases:=0;
  398. count(root);
  399. end;
  400. function case_get_max(root : pcaselabel) : tconstexprint;
  401. var
  402. hp : pcaselabel;
  403. begin
  404. hp:=root;
  405. while assigned(hp^.greater) do
  406. hp:=hp^.greater;
  407. case_get_max:=hp^._high;
  408. end;
  409. function case_get_min(root : pcaselabel) : tconstexprint;
  410. var
  411. hp : pcaselabel;
  412. begin
  413. hp:=root;
  414. while assigned(hp^.less) do
  415. hp:=hp^.less;
  416. case_get_min:=hp^._low;
  417. end;
  418. procedure deletecaselabels(p : pcaselabel);
  419. begin
  420. if assigned(p^.greater) then
  421. deletecaselabels(p^.greater);
  422. if assigned(p^.less) then
  423. deletecaselabels(p^.less);
  424. if (p^.label_type = ltConstString) then
  425. begin
  426. p^._low_str.Free;
  427. p^._high_str.Free;
  428. end;
  429. dispose(p);
  430. end;
  431. function copycaselabel(p : pcaselabel) : pcaselabel;
  432. var
  433. n : pcaselabel;
  434. begin
  435. new(n);
  436. n^:=p^;
  437. if (p^.label_type = ltConstString) then
  438. begin
  439. n^._low_str := tstringconstnode(p^._low_str.getcopy);
  440. n^._high_str := tstringconstnode(p^._high_str.getcopy);
  441. end;
  442. if assigned(p^.greater) then
  443. n^.greater:=copycaselabel(p^.greater);
  444. if assigned(p^.less) then
  445. n^.less:=copycaselabel(p^.less);
  446. copycaselabel:=n;
  447. end;
  448. procedure ppuwritecaselabel(ppufile:tcompilerppufile;p : pcaselabel);
  449. var
  450. b : byte;
  451. begin
  452. ppufile.putboolean(p^.label_type = ltConstString);
  453. if (p^.label_type = ltConstString) then
  454. begin
  455. p^._low_str.ppuwrite(ppufile);
  456. p^._high_str.ppuwrite(ppufile);
  457. end
  458. else
  459. begin
  460. ppufile.putexprint(p^._low);
  461. ppufile.putexprint(p^._high);
  462. end;
  463. ppufile.putlongint(p^.blockid);
  464. b:=ord(assigned(p^.greater)) or (ord(assigned(p^.less)) shl 1);
  465. ppufile.putbyte(b);
  466. if assigned(p^.greater) then
  467. ppuwritecaselabel(ppufile,p^.greater);
  468. if assigned(p^.less) then
  469. ppuwritecaselabel(ppufile,p^.less);
  470. end;
  471. function ppuloadcaselabel(ppufile:tcompilerppufile):pcaselabel;
  472. var
  473. b : byte;
  474. p : pcaselabel;
  475. begin
  476. new(p);
  477. if ppufile.getboolean then
  478. begin
  479. p^.label_type := ltConstString;
  480. p^._low_str := cstringconstnode.ppuload(stringconstn,ppufile);
  481. p^._high_str := cstringconstnode.ppuload(stringconstn,ppufile);
  482. end
  483. else
  484. begin
  485. p^.label_type := ltOrdinal;
  486. p^._low:=ppufile.getexprint;
  487. p^._high:=ppufile.getexprint;
  488. end;
  489. p^.blockid:=ppufile.getlongint;
  490. b:=ppufile.getbyte;
  491. if (b and 1)=1 then
  492. p^.greater:=ppuloadcaselabel(ppufile)
  493. else
  494. p^.greater:=nil;
  495. if (b and 2)=2 then
  496. p^.less:=ppuloadcaselabel(ppufile)
  497. else
  498. p^.less:=nil;
  499. ppuloadcaselabel:=p;
  500. end;
  501. {*****************************************************************************
  502. TCASENODE
  503. *****************************************************************************}
  504. constructor tcasenode.create(l:tnode);
  505. begin
  506. inherited create(casen,l);
  507. flabels:=nil;
  508. blocks:=TFPList.create;
  509. elseblock:=nil;
  510. end;
  511. destructor tcasenode.destroy;
  512. var
  513. i : longint;
  514. hp : pcaseblock;
  515. begin
  516. elseblock.free;
  517. deletecaselabels(flabels);
  518. for i:=0 to blocks.count-1 do
  519. begin
  520. pcaseblock(blocks[i])^.statement.free;
  521. hp:=pcaseblock(blocks[i]);
  522. dispose(hp);
  523. end;
  524. blocks.free;
  525. inherited destroy;
  526. end;
  527. constructor tcasenode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
  528. var
  529. cnt,i : longint;
  530. begin
  531. inherited ppuload(t,ppufile);
  532. elseblock:=ppuloadnode(ppufile);
  533. cnt:=ppufile.getlongint();
  534. blocks:=TFPList.create;
  535. for i:=0 to cnt-1 do
  536. addblock(i,ppuloadnode(ppufile));
  537. flabels:=ppuloadcaselabel(ppufile);
  538. { we don't save/restore the label counts, but recalculate them if needed }
  539. fcountsuptodate:=false;
  540. end;
  541. procedure tcasenode.ppuwrite(ppufile:tcompilerppufile);
  542. var
  543. i : longint;
  544. begin
  545. inherited ppuwrite(ppufile);
  546. ppuwritenode(ppufile,elseblock);
  547. ppufile.putlongint(blocks.count);
  548. for i:=0 to blocks.count-1 do
  549. ppuwritenode(ppufile,pcaseblock(blocks[i])^.statement);
  550. ppuwritecaselabel(ppufile,flabels);
  551. { we don't save/restore the label counts, but recalculate them if needed }
  552. end;
  553. procedure tcasenode.buildderefimpl;
  554. var
  555. i : integer;
  556. begin
  557. inherited buildderefimpl;
  558. if assigned(elseblock) then
  559. elseblock.buildderefimpl;
  560. for i:=0 to blocks.count-1 do
  561. pcaseblock(blocks[i])^.statement.buildderefimpl;
  562. end;
  563. procedure tcasenode.derefimpl;
  564. var
  565. i : integer;
  566. begin
  567. inherited derefimpl;
  568. if assigned(elseblock) then
  569. elseblock.derefimpl;
  570. for i:=0 to blocks.count-1 do
  571. pcaseblock(blocks[i])^.statement.derefimpl;
  572. end;
  573. function tcasenode.pass_typecheck : tnode;
  574. var
  575. i : integer;
  576. begin
  577. result:=nil;
  578. do_typecheckpass(left);
  579. for i:=0 to blocks.count-1 do
  580. typecheckpass(pcaseblock(blocks[i])^.statement);
  581. if assigned(elseblock) then
  582. typecheckpass(elseblock);
  583. resultdef:=voidtype;
  584. result:=simplify(false);
  585. end;
  586. type
  587. TLinkedListCaseLabelItem = class(TLinkedListItem)
  588. casenode: pcaselabel;
  589. constructor create(c: pcaselabel);
  590. end;
  591. constructor TLinkedListCaseLabelItem.create(c: pcaselabel);
  592. begin
  593. inherited create;
  594. casenode:=c;
  595. end;
  596. function tcasenode.pass_1 : tnode;
  597. var
  598. i: integer;
  599. node_thenblock, node_elseblock, if_node,temp_cleanup : tnode;
  600. tempcaseexpr : ttempcreatenode;
  601. if_block, init_block: tblocknode;
  602. stmt: tstatementnode;
  603. procedure add_label_to_blockid_list(list: tfpobjectlist; lab: pcaselabel);
  604. begin
  605. if not assigned(lab) then
  606. exit;
  607. if not assigned(list[lab^.blockid]) then
  608. list[lab^.blockid]:=tfpobjectlist.create(true);
  609. tfpobjectlist(list[lab^.blockid]).add(TLinkedListCaseLabelItem.create(lab));
  610. add_label_to_blockid_list(list,lab^.less);
  611. add_label_to_blockid_list(list,lab^.greater);
  612. end;
  613. function order_labels_by_blockid: tfpobjectlist;
  614. begin
  615. result:=tfpobjectlist.create(true);
  616. result.count:=blocks.count;
  617. add_label_to_blockid_list(result,flabels);
  618. end;
  619. function makeifblock(elseblock : tnode): tnode;
  620. var
  621. i, j: longint;
  622. check: taddnode;
  623. newcheck: ^taddnode;
  624. blocklist, lablist: tfpobjectlist;
  625. labitem: pcaselabel;
  626. begin
  627. result:=elseblock;
  628. blocklist:=order_labels_by_blockid;
  629. { in reverse order so that the case options at the start of the case
  630. statement are evaluated first, as they presumably are the most
  631. common }
  632. for i:=blocklist.count-1 downto 0 do
  633. begin
  634. lablist:=tfpobjectlist(blocklist[i]);
  635. check:=nil;
  636. for j:=0 to lablist.count-1 do
  637. begin
  638. if assigned(check) then
  639. begin
  640. check:=caddnode.create(orn,check,nil);
  641. newcheck:[email protected]
  642. end
  643. else
  644. newcheck:=@check;
  645. labitem:=TLinkedListCaseLabelItem(lablist[j]).casenode;
  646. newcheck^:=caddnode.create(equaln,left.getcopy,labitem^._low_str.getcopy);
  647. if (labitem^._low_str.fullcompare(labitem^._high_str)<>0) then
  648. begin
  649. newcheck^.nodetype:=gten;
  650. newcheck^:=caddnode.create(
  651. andn,newcheck^,caddnode.create(
  652. lten,left.getcopy,labitem^._high_str.getcopy));
  653. end;
  654. end;
  655. result:=cifnode.create(check,
  656. pcaseblock(blocks[i])^.statement,result);
  657. pcaseblock(blocks[i])^.statement:=nil;
  658. end;
  659. { will free its elements too because of create(true) }
  660. blocklist.free;
  661. typecheckpass(result);
  662. end;
  663. begin
  664. result:=nil;
  665. init_block:=nil;
  666. temp_cleanup:=nil;
  667. expectloc:=LOC_VOID;
  668. { only do in pass_1, so that simplify can run first and
  669. 1) possibly simplify the case node without triggering a warning
  670. 2) possibly give a compile-time error if not all cases are handled
  671. in ISO/Extended Pascal mode }
  672. if is_ordinal(left.resultdef) then
  673. checkordinalcoverage;
  674. { ideally this would be in simplify, but then checkordinalcoverage can
  675. false positives about case statements not handling all cases }
  676. if assigned(elseblock) and
  677. has_no_code(elseblock) then
  678. begin
  679. elseblock.free;
  680. elseblock:=nil;
  681. end;
  682. { evalutes the case expression }
  683. firstpass(left);
  684. set_varstate(left,vs_read,[vsf_must_be_valid]);
  685. if codegenerror then
  686. exit;
  687. { Load caseexpr into temp var if complex. }
  688. { No need to do this for ordinal, because }
  689. { in that case caseexpr is generated once }
  690. if (flabels^.label_type = ltConstString) and (not valid_for_addr(left, false)) and
  691. (blocks.count > 0) then
  692. begin
  693. init_block := internalstatements(stmt);
  694. tempcaseexpr :=
  695. ctempcreatenode.create(
  696. left.resultdef, left.resultdef.size, tt_persistent, true);
  697. temp_cleanup := ctempdeletenode.create(tempcaseexpr);
  698. typecheckpass(tnode(tempcaseexpr));
  699. addstatement(stmt, tempcaseexpr);
  700. addstatement(
  701. stmt, cassignmentnode.create(
  702. ctemprefnode.create(tempcaseexpr), left));
  703. left := ctemprefnode.create(tempcaseexpr);
  704. typecheckpass(left);
  705. end;
  706. { first case }
  707. for i:=0 to blocks.count-1 do
  708. firstpass(pcaseblock(blocks[i])^.statement);
  709. { may be handle else tree }
  710. if assigned(elseblock) then
  711. begin
  712. firstpass(elseblock);
  713. { kill case? }
  714. if blocks.count=0 then
  715. begin
  716. result:=elseblock;
  717. elseblock:=nil;
  718. exit;
  719. end;
  720. end
  721. else
  722. if blocks.count=0 then
  723. begin
  724. result:=cnothingnode.create;
  725. exit;
  726. end;
  727. if (flabels^.label_type = ltConstString) then
  728. begin
  729. if_node:=makeifblock(elseblock);
  730. if assigned(init_block) then
  731. firstpass(tnode(init_block));
  732. if_block:=internalstatements(stmt);
  733. if assigned(init_block) then
  734. addstatement(stmt, init_block);
  735. addstatement(stmt,if_node);
  736. if assigned(temp_cleanup) then
  737. addstatement(stmt,temp_cleanup);
  738. result:=if_block;
  739. elseblock:= nil;
  740. exit;
  741. end;
  742. if is_boolean(left.resultdef) then
  743. begin
  744. case blocks.count of
  745. 2:
  746. begin
  747. if boolean(qword(flabels^._low))=false then
  748. begin
  749. node_thenblock:=pcaseblock(blocks[flabels^.greater^.blockid])^.statement;
  750. node_elseblock:=pcaseblock(blocks[flabels^.blockid])^.statement;
  751. pcaseblock(blocks[flabels^.greater^.blockid])^.statement:=nil;
  752. end
  753. else
  754. begin
  755. node_thenblock:=pcaseblock(blocks[flabels^.blockid])^.statement;
  756. node_elseblock:=pcaseblock(blocks[flabels^.less^.blockid])^.statement;
  757. pcaseblock(blocks[flabels^.less^.blockid])^.statement:=nil;
  758. end;
  759. pcaseblock(blocks[flabels^.blockid])^.statement:=nil;
  760. end;
  761. 1:
  762. begin
  763. if flabels^._low=flabels^._high then
  764. begin
  765. if boolean(qword(flabels^._low))=false then
  766. begin
  767. node_thenblock:=elseblock;
  768. node_elseblock:=pcaseblock(blocks[flabels^.blockid])^.statement;
  769. end
  770. else
  771. begin
  772. node_thenblock:=pcaseblock(blocks[flabels^.blockid])^.statement;
  773. node_elseblock:=elseblock;
  774. end;
  775. pcaseblock(blocks[flabels^.blockid])^.statement:=nil;
  776. elseblock:=nil;
  777. end
  778. else
  779. begin
  780. result:=pcaseblock(blocks[flabels^.blockid])^.statement;
  781. pcaseblock(blocks[flabels^.blockid])^.statement:=nil;
  782. elseblock:=nil;
  783. exit;
  784. end;
  785. end;
  786. else
  787. internalerror(200805031);
  788. end;
  789. result:=cifnode.create(left,node_thenblock,node_elseblock);
  790. left:=nil;
  791. exit;
  792. end;
  793. { convert single case branch into if-statement }
  794. if (flabels^.greater=nil) and (flabels^.less=nil) then
  795. if flabels^.label_type=ltOrdinal then
  796. begin
  797. if flabels^._low=flabels^._high then
  798. begin
  799. result:=cifnode.create_internal(
  800. caddnode.create_internal(equaln,left.getcopy,cordconstnode.create(flabels^._low,left.resultdef,false)),
  801. pcaseblock(blocks[flabels^.blockid])^.statement,elseblock);
  802. end
  803. else
  804. begin
  805. result:=cifnode.create_internal(
  806. caddnode.create_internal(andn,
  807. caddnode.create_internal(gten,left.getcopy,cordconstnode.create(flabels^._low,left.resultdef,false)),
  808. caddnode.create_internal(lten,left.getcopy,cordconstnode.create(flabels^._high,left.resultdef,false))
  809. ),
  810. pcaseblock(blocks[flabels^.blockid])^.statement,elseblock);
  811. end;
  812. elseblock:=nil;
  813. pcaseblock(blocks[flabels^.blockid])^.statement:=nil;
  814. exit;
  815. end;
  816. end;
  817. function tcasenode.simplify(forinline:boolean):tnode;
  818. var
  819. tmp: pcaselabel;
  820. begin
  821. result:=nil;
  822. if left.nodetype=ordconstn then
  823. begin
  824. tmp:=flabels;
  825. { check all case labels until we find one that fits }
  826. while assigned(tmp) do
  827. begin
  828. if (tmp^._low<=tordconstnode(left).value) and
  829. (tmp^._high>=tordconstnode(left).value) then
  830. begin
  831. if tmp^.blockid>=blocks.count then
  832. internalerror(2014022101);
  833. result:=pcaseblock(blocks[tmp^.blockid])^.statement;
  834. if not assigned(result) then
  835. internalerror(2014022102);
  836. result:=result.getcopy;
  837. exit;
  838. end;
  839. if tmp^._high<tordconstnode(left).value then
  840. tmp:=tmp^.greater
  841. else
  842. tmp:=tmp^.less;
  843. end;
  844. { no label did match; use the else block if available }
  845. if assigned(elseblock) then
  846. result:=elseblock.getcopy
  847. else
  848. begin
  849. if ([m_iso,m_extpas]*current_settings.modeswitches)<>[] then
  850. cgmessage1(cg_e_case_missing_value,tostr(tordconstnode(left).value))
  851. else
  852. cgmessage(cg_w_case_incomplete);
  853. { no else block, so there is no code to execute at all }
  854. result:=cnothingnode.create;
  855. end;
  856. end;
  857. end;
  858. function tcasenode.dogetcopy : tnode;
  859. var
  860. n : tcasenode;
  861. i : longint;
  862. begin
  863. n:=tcasenode(inherited dogetcopy);
  864. if assigned(elseblock) then
  865. n.elseblock:=elseblock.dogetcopy
  866. else
  867. n.elseblock:=nil;
  868. if assigned(flabels) then
  869. n.flabels:=copycaselabel(flabels)
  870. else
  871. n.flabels:=nil;
  872. if assigned(blocks) then
  873. begin
  874. n.blocks:=TFPList.create;
  875. for i:=0 to blocks.count-1 do
  876. begin
  877. if not assigned(blocks[i]) then
  878. internalerror(200411302);
  879. n.addblock(i,pcaseblock(blocks[i])^.statement.dogetcopy);
  880. end;
  881. end
  882. else
  883. n.blocks:=nil;
  884. n.fcountsuptodate:=fcountsuptodate;
  885. n.flabelcnt:=flabelcnt;
  886. n.flabelcoverage:=flabelcoverage;
  887. dogetcopy:=n;
  888. end;
  889. procedure tcasenode.printnodetree(var t: text);
  890. var
  891. i : longint;
  892. begin
  893. write(t,printnodeindention,'(');
  894. printnodeindent;
  895. printnodeinfo(t);
  896. writeln(t);
  897. printnode(t,left);
  898. i:=0;
  899. for i:=0 to blocks.count-1 do
  900. begin
  901. writeln(t,printnodeindention,'(caseblock blockid: ',i);
  902. printnodeindent;
  903. printnode(t,pcaseblock(blocks[i])^.statement);
  904. printnodeunindent;
  905. writeln(t,printnodeindention,')');
  906. end;
  907. if assigned(elseblock) then
  908. begin
  909. writeln(t,printnodeindention,'(else: ',i);
  910. printnodeindent;
  911. printnode(t,elseblock);
  912. printnodeunindent;
  913. writeln(t,printnodeindention,')');
  914. end;
  915. printnodeunindent;
  916. writeln(t,printnodeindention,')');
  917. end;
  918. {$ifdef DEBUG_NODE_XML}
  919. procedure TCaseNode.XMLPrintNodeTree(var T: Text);
  920. var
  921. i : longint;
  922. begin
  923. Write(T, PrintNodeIndention, '<', nodetype2str[nodetype]);
  924. XMLPrintNodeInfo(T);
  925. WriteLn(T, '>');
  926. PrintNodeIndent;
  927. WriteLn(T, PrintNodeIndention, '<condition>');
  928. PrintNodeIndent;
  929. XMLPrintNode(T, Left);
  930. PrintNodeUnindent;
  931. WriteLn(T, PrintNodeIndention, '</condition>');
  932. i:=0;
  933. for i:=0 to blocks.count-1 do
  934. begin
  935. WriteLn(T, PrintNodeIndention, '<block id="', i, '">');
  936. PrintNodeIndent;
  937. XMLPrintNode(T, PCaseBlock(blocks[i])^.statement);
  938. PrintNodeUnindent;
  939. WriteLn(T, PrintNodeIndention, '</block>');
  940. end;
  941. if assigned(elseblock) then
  942. begin
  943. WriteLn(T, PrintNodeIndention, '<block id="else">');;
  944. PrintNodeIndent;
  945. XMLPrintNode(T, ElseBlock);
  946. PrintNodeUnindent;
  947. WriteLn(T, PrintNodeIndention, '</block>');
  948. end;
  949. PrintNodeUnindent;
  950. WriteLn(T, PrintNodeIndention, '</', nodetype2str[nodetype], '>');
  951. end;
  952. {$endif DEBUG_NODE_XML}
  953. procedure tcasenode.insertintolist(l : tnodelist);
  954. begin
  955. end;
  956. function caselabelsequal(n1,n2: pcaselabel): boolean;
  957. begin
  958. result :=
  959. (not assigned(n1) and not assigned(n2)) or
  960. (assigned(n1) and assigned(n2) and
  961. (n1^._low = n2^._low) and
  962. (n1^._high = n2^._high) and
  963. { the rest of the fields don't matter for equality (JM) }
  964. caselabelsequal(n1^.less,n2^.less) and
  965. caselabelsequal(n1^.greater,n2^.greater))
  966. end;
  967. function caseblocksequal(b1,b2:TFPList): boolean;
  968. var
  969. i : longint;
  970. begin
  971. result:=false;
  972. if b1.count<>b2.count then
  973. exit;
  974. for i:=0 to b1.count-1 do
  975. begin
  976. if not pcaseblock(b1[i])^.statement.isequal(pcaseblock(b2[i])^.statement) then
  977. exit;
  978. end;
  979. result:=true;
  980. end;
  981. function tcasenode.docompare(p: tnode): boolean;
  982. begin
  983. result :=
  984. inherited docompare(p) and
  985. caselabelsequal(flabels,tcasenode(p).flabels) and
  986. caseblocksequal(blocks,tcasenode(p).blocks) and
  987. elseblock.isequal(tcasenode(p).elseblock);
  988. end;
  989. procedure tcasenode.addblock(blockid:longint;instr:tnode);
  990. var
  991. hcaseblock : pcaseblock;
  992. begin
  993. new(hcaseblock);
  994. fillchar(hcaseblock^,sizeof(hcaseblock^),0);
  995. hcaseblock^.statement:=instr;
  996. if blockid>=blocks.count then
  997. blocks.count:=blockid+1;
  998. blocks[blockid]:=hcaseblock;
  999. end;
  1000. procedure tcasenode.addelseblock(instr:tnode);
  1001. begin
  1002. elseblock:=instr;
  1003. end;
  1004. function tcasenode.getlabelcnt: cardinal;
  1005. begin
  1006. if not fcountsuptodate then
  1007. updatecoverage;
  1008. result:=flabelcnt;
  1009. end;
  1010. function tcasenode.getlabelcoverage: qword;
  1011. begin
  1012. if not fcountsuptodate then
  1013. updatecoverage;
  1014. result:=flabelcoverage;
  1015. end;
  1016. procedure tcasenode.updatecoverage;
  1017. var
  1018. isord, first: boolean;
  1019. procedure count(p : pcaselabel);
  1020. begin
  1021. inc(flabelcnt);
  1022. if isord then
  1023. begin
  1024. flabelcoverage:=flabelcoverage + (p^._high - p^._low);
  1025. { ensure we don't overflow in case it covers the
  1026. full range of qword }
  1027. if not first then
  1028. inc(flabelcoverage);
  1029. first:=false;
  1030. end;
  1031. if assigned(p^.less) then
  1032. count(p^.less);
  1033. if assigned(p^.greater) then
  1034. count(p^.greater);
  1035. end;
  1036. begin
  1037. isord:=is_ordinal(left.resultdef);
  1038. flabelcnt:=0;
  1039. flabelcoverage:=0;
  1040. first:=true;
  1041. count(flabels);
  1042. fcountsuptodate:=true;
  1043. end;
  1044. procedure tcasenode.checkordinalcoverage;
  1045. function orddefspansfullrange(def: torddef): boolean;
  1046. var
  1047. packedbitsize: cardinal;
  1048. dummy: longint;
  1049. val: qword;
  1050. begin
  1051. result:=false;
  1052. packedbitsize:=def.packedbitsize;
  1053. if ((packedbitsize mod 8) <> 0) or
  1054. not ispowerof2(packedbitsize div 8,dummy) then
  1055. exit;
  1056. dec(packedbitsize);
  1057. if is_signed(def) then
  1058. begin
  1059. {$push}{$q-}
  1060. if def.low<>(-(int64(1) shl packedbitsize)) then
  1061. exit;
  1062. if def.high<>((int64(1) shl packedbitsize)-1) then
  1063. exit;
  1064. {$pop}
  1065. end
  1066. else
  1067. begin
  1068. if def.low<>0 then
  1069. exit;
  1070. val:=qword(1) shl packedbitsize;
  1071. val:=(val-1)+val;
  1072. if def.high<>val then
  1073. exit;
  1074. end;
  1075. result:=true;
  1076. end;
  1077. var
  1078. lv, hv, typcount: tconstexprint;
  1079. begin
  1080. { Check label type coverage for enumerations and small types }
  1081. getrange(left.resultdef,lv,hv);
  1082. typcount:=hv-lv;
  1083. if not assigned(elseblock) then
  1084. begin
  1085. { unless cs_check_all_case_coverage is set, only check for enums, booleans and
  1086. subrange types different from the default ones }
  1087. if (cs_check_all_case_coverage in current_settings.localswitches) or
  1088. (is_enum(left.resultdef) or
  1089. is_boolean(left.resultdef) or
  1090. not orddefspansfullrange(torddef(left.resultdef))) and
  1091. (labelcoverage<typcount) then
  1092. begin
  1093. { labels for some values of the operand are missing, and no else block is present }
  1094. cgmessage(cg_w_case_incomplete);
  1095. { in Standard/Extended Pascal, this is a dynamic violation error if it actually happens }
  1096. if ([m_extpas,m_iso]*current_settings.modeswitches)<>[] then
  1097. begin
  1098. elseblock:=ccallnode.createintern('fpc_rangeerror',nil);
  1099. typecheckpass(elseblock);
  1100. end;
  1101. end
  1102. end
  1103. else if labelcoverage=typcount then
  1104. begin
  1105. { labels for all values of the operand are present, but an extra else block is present }
  1106. MessagePos(elseblock.fileinfo, cg_w_unreachable_code);
  1107. end;
  1108. end;
  1109. procedure tcasenode.addlabel(blockid:longint;const l,h : TConstExprInt);
  1110. var
  1111. hcaselabel : pcaselabel;
  1112. function insertlabel(var p : pcaselabel):pcaselabel;
  1113. begin
  1114. if p=nil then
  1115. begin
  1116. p:=hcaselabel;
  1117. result:=p;
  1118. end
  1119. else
  1120. if (p^._low>hcaselabel^._low) and
  1121. (p^._low>hcaselabel^._high) then
  1122. begin
  1123. if (hcaselabel^.blockid = p^.blockid) and
  1124. (p^._low = hcaselabel^._high + 1) then
  1125. begin
  1126. p^._low := hcaselabel^._low;
  1127. dispose(hcaselabel);
  1128. result:=p;
  1129. end
  1130. else
  1131. result:=insertlabel(p^.less)
  1132. end
  1133. else
  1134. if (p^._high<hcaselabel^._low) and
  1135. (p^._high<hcaselabel^._high) then
  1136. begin
  1137. if (hcaselabel^.blockid = p^.blockid) and
  1138. (p^._high+1 = hcaselabel^._low) then
  1139. begin
  1140. p^._high := hcaselabel^._high;
  1141. dispose(hcaselabel);
  1142. result:=p;
  1143. end
  1144. else
  1145. result:=insertlabel(p^.greater);
  1146. end
  1147. else
  1148. begin
  1149. dispose(hcaselabel);
  1150. Message(parser_e_double_caselabel);
  1151. result:=nil;
  1152. end
  1153. end;
  1154. begin
  1155. new(hcaselabel);
  1156. fillchar(hcaselabel^,sizeof(tcaselabel),0);
  1157. hcaselabel^.blockid:=blockid;
  1158. hcaselabel^.label_type:=ltOrdinal;
  1159. hcaselabel^._low:=l;
  1160. hcaselabel^._high:=h;
  1161. insertlabel(flabels);
  1162. fcountsuptodate:=false;
  1163. end;
  1164. procedure tcasenode.addlabel(blockid: longint; l, h: tstringconstnode);
  1165. var
  1166. hcaselabel : pcaselabel;
  1167. function insertlabel(var p : pcaselabel) : pcaselabel;
  1168. begin
  1169. if not assigned(p) then
  1170. begin
  1171. p := hcaselabel;
  1172. result := p;
  1173. end
  1174. else
  1175. if (p^._low_str.fullcompare(hcaselabel^._high_str) > 0) then
  1176. result := insertlabel(p^.less)
  1177. else
  1178. if (p^._high_str.fullcompare(hcaselabel^._low_str) < 0) then
  1179. result := insertlabel(p^.greater)
  1180. else
  1181. begin
  1182. hcaselabel^._low_str.free;
  1183. hcaselabel^._high_str.free;
  1184. dispose(hcaselabel);
  1185. Message(parser_e_double_caselabel);
  1186. result:=nil;
  1187. end;
  1188. end;
  1189. begin
  1190. new(hcaselabel);
  1191. fillchar(hcaselabel^, sizeof(tcaselabel), 0);
  1192. hcaselabel^.blockid := blockid;
  1193. hcaselabel^.label_type := ltConstString;
  1194. hcaselabel^._low_str := tstringconstnode(l.getcopy);
  1195. hcaselabel^._high_str := tstringconstnode(h.getcopy);
  1196. insertlabel(flabels);
  1197. end;
  1198. end.