nset.pas 44 KB

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