nmat.pas 32 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045
  1. {
  2. Copyright (c) 2000-2005 by Florian Klaempfl
  3. Type checking and register allocation for math 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 nmat;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. node;
  22. type
  23. tmoddivnode = class(tbinopnode)
  24. function pass_1 : tnode;override;
  25. function pass_typecheck:tnode;override;
  26. function simplify(forinline : boolean) : tnode;override;
  27. protected
  28. {$ifndef cpu64bitalu}
  29. { override the following if you want to implement }
  30. { parts explicitely in the code generator (JM) }
  31. function first_moddiv64bitint: tnode; virtual;
  32. {$endif not cpu64bitalu}
  33. function firstoptimize: tnode; virtual;
  34. function first_moddivint: tnode; virtual;
  35. end;
  36. tmoddivnodeclass = class of tmoddivnode;
  37. tshlshrnode = class(tbinopnode)
  38. function pass_1 : tnode;override;
  39. function pass_typecheck:tnode;override;
  40. function simplify(forinline : boolean) : tnode;override;
  41. {$ifndef cpu64bitalu}
  42. { override the following if you want to implement }
  43. { parts explicitely in the code generator (CEC)
  44. Should return nil, if everything will be handled
  45. in the code generator
  46. }
  47. function first_shlshr64bitint: tnode; virtual;
  48. {$endif not cpu64bitalu}
  49. end;
  50. tshlshrnodeclass = class of tshlshrnode;
  51. tunaryminusnode = class(tunarynode)
  52. constructor create(expr : tnode);virtual;
  53. function pass_1 : tnode;override;
  54. function pass_typecheck:tnode;override;
  55. function simplify(forinline : boolean) : tnode;override;
  56. end;
  57. tunaryminusnodeclass = class of tunaryminusnode;
  58. tunaryplusnode = class(tunarynode)
  59. constructor create(expr : tnode);virtual;
  60. function pass_1 : tnode;override;
  61. function pass_typecheck:tnode;override;
  62. end;
  63. tunaryplusnodeclass = class of tunaryplusnode;
  64. tnotnode = class(tunarynode)
  65. constructor create(expr : tnode);virtual;
  66. function pass_1 : tnode;override;
  67. function pass_typecheck:tnode;override;
  68. function simplify(forinline : boolean) : tnode;override;
  69. {$ifdef state_tracking}
  70. function track_state_pass(exec_known:boolean):boolean;override;
  71. {$endif}
  72. end;
  73. tnotnodeclass = class of tnotnode;
  74. var
  75. cmoddivnode : tmoddivnodeclass = tmoddivnode;
  76. cshlshrnode : tshlshrnodeclass = tshlshrnode;
  77. cunaryminusnode : tunaryminusnodeclass = tunaryminusnode;
  78. cunaryplusnode : tunaryplusnodeclass = tunaryplusnode;
  79. cnotnode : tnotnodeclass = tnotnode;
  80. implementation
  81. uses
  82. systems,
  83. verbose,globals,cutils,
  84. globtype,constexp,
  85. symconst,symtype,symdef,symtable,
  86. defutil,
  87. htypechk,pass_1,
  88. cgbase,
  89. ncon,ncnv,ncal,nadd,
  90. nutils;
  91. {****************************************************************************
  92. TMODDIVNODE
  93. ****************************************************************************}
  94. function tmoddivnode.simplify(forinline : boolean):tnode;
  95. var
  96. rv,lv : tconstexprint;
  97. begin
  98. result:=nil;
  99. if is_constintnode(right) then
  100. begin
  101. if tordconstnode(right).value = 1 then
  102. begin
  103. case nodetype of
  104. modn:
  105. result := cordconstnode.create(0,left.resultdef,true);
  106. divn:
  107. result := left.getcopy;
  108. end;
  109. exit;
  110. end;
  111. if tordconstnode(right).value = 0 then
  112. begin
  113. Message(parser_e_division_by_zero);
  114. { recover }
  115. tordconstnode(right).value := 1;
  116. end;
  117. end;
  118. if is_constintnode(right) and is_constintnode(left) then
  119. begin
  120. rv:=tordconstnode(right).value;
  121. lv:=tordconstnode(left).value;
  122. case nodetype of
  123. modn:
  124. result:=create_simplified_ord_const(lv mod rv,resultdef,forinline);
  125. divn:
  126. result:=create_simplified_ord_const(lv div rv,resultdef,forinline);
  127. end;
  128. end;
  129. end;
  130. function tmoddivnode.pass_typecheck:tnode;
  131. var
  132. hp,t : tnode;
  133. rd,ld : torddef;
  134. begin
  135. result:=nil;
  136. typecheckpass(left);
  137. typecheckpass(right);
  138. set_varstate(left,vs_read,[vsf_must_be_valid]);
  139. set_varstate(right,vs_read,[vsf_must_be_valid]);
  140. if codegenerror then
  141. exit;
  142. { tp procvar support }
  143. maybe_call_procvar(left,true);
  144. maybe_call_procvar(right,true);
  145. result:=simplify(false);
  146. if assigned(result) then
  147. exit;
  148. { allow operator overloading }
  149. t:=self;
  150. if isbinaryoverloaded(t) then
  151. begin
  152. result:=t;
  153. exit;
  154. end;
  155. { we need 2 orddefs always }
  156. if (left.resultdef.typ<>orddef) then
  157. inserttypeconv(right,sinttype);
  158. if (right.resultdef.typ<>orddef) then
  159. inserttypeconv(right,sinttype);
  160. if codegenerror then
  161. exit;
  162. rd:=torddef(right.resultdef);
  163. ld:=torddef(left.resultdef);
  164. { if one operand is a cardinal and the other is a positive constant, convert the }
  165. { constant to a cardinal as well so we don't have to do a 64bit division (JM) }
  166. { Do the same for qwords and positive constants as well, otherwise things like }
  167. { "qword mod 10" are evaluated with int64 as result, which is wrong if the }
  168. { "qword" was > high(int64) (JM) }
  169. { Additionally, do the same for cardinal/qwords and other positive types, but }
  170. { always in a way that a smaller type is converted to a bigger type }
  171. { (webtbs/tw8870) }
  172. if (rd.ordtype in [u32bit,u64bit]) and
  173. ((is_constintnode(left) and
  174. (tordconstnode(left).value >= 0)) or
  175. (not is_signed(ld) and
  176. (rd.size >= ld.size))) then
  177. begin
  178. inserttypeconv(left,right.resultdef);
  179. ld:=torddef(left.resultdef);
  180. end;
  181. if (ld.ordtype in [u32bit,u64bit]) and
  182. ((is_constintnode(right) and
  183. (tordconstnode(right).value >= 0)) or
  184. (not is_signed(rd) and
  185. (ld.size >= rd.size))) then
  186. begin
  187. inserttypeconv(right,left.resultdef);
  188. rd:=torddef(right.resultdef);
  189. end;
  190. { when there is one currency value, everything is done
  191. using currency }
  192. if (ld.ordtype=scurrency) or
  193. (rd.ordtype=scurrency) then
  194. begin
  195. if (ld.ordtype<>scurrency) then
  196. inserttypeconv(left,s64currencytype);
  197. if (rd.ordtype<>scurrency) then
  198. inserttypeconv(right,s64currencytype);
  199. resultdef:=left.resultdef;
  200. end
  201. else
  202. {$ifndef cpu64bitaddr}
  203. { when there is one 64bit value, everything is done
  204. in 64bit }
  205. if (is_64bitint(left.resultdef) or
  206. is_64bitint(right.resultdef)) then
  207. begin
  208. if is_signed(rd) or is_signed(ld) then
  209. begin
  210. if (ld.ordtype<>s64bit) then
  211. inserttypeconv(left,s64inttype);
  212. if (rd.ordtype<>s64bit) then
  213. inserttypeconv(right,s64inttype);
  214. end
  215. else
  216. begin
  217. if (ld.ordtype<>u64bit) then
  218. inserttypeconv(left,u64inttype);
  219. if (rd.ordtype<>u64bit) then
  220. inserttypeconv(right,u64inttype);
  221. end;
  222. resultdef:=left.resultdef;
  223. end
  224. else
  225. { when mixing cardinals and signed numbers, convert everythign to 64bit (JM) }
  226. if ((rd.ordtype = u32bit) and
  227. is_signed(ld)) or
  228. ((ld.ordtype = u32bit) and
  229. is_signed(rd)) then
  230. begin
  231. CGMessage(type_h_mixed_signed_unsigned);
  232. if (ld.ordtype<>s64bit) then
  233. inserttypeconv(left,s64inttype);
  234. if (rd.ordtype<>s64bit) then
  235. inserttypeconv(right,s64inttype);
  236. resultdef:=left.resultdef;
  237. end
  238. else
  239. {$endif not cpu64bitaddr}
  240. begin
  241. { Make everything always default singed int }
  242. if not(rd.ordtype in [torddef(sinttype).ordtype,torddef(uinttype).ordtype]) then
  243. inserttypeconv(right,sinttype);
  244. if not(ld.ordtype in [torddef(sinttype).ordtype,torddef(uinttype).ordtype]) then
  245. inserttypeconv(left,sinttype);
  246. resultdef:=right.resultdef;
  247. end;
  248. { when the result is currency we need some extra code for
  249. division. this should not be done when the divn node is
  250. created internally }
  251. if (nodetype=divn) and
  252. not(nf_is_currency in flags) and
  253. is_currency(resultdef) then
  254. begin
  255. hp:=caddnode.create(muln,getcopy,cordconstnode.create(10000,s64currencytype,false));
  256. include(hp.flags,nf_is_currency);
  257. result:=hp;
  258. end;
  259. end;
  260. function tmoddivnode.first_moddivint: tnode;
  261. {$ifdef cpuneedsdiv32helper}
  262. var
  263. procname: string[31];
  264. begin
  265. result := nil;
  266. { otherwise create a call to a helper }
  267. if nodetype = divn then
  268. procname := 'fpc_div_'
  269. else
  270. procname := 'fpc_mod_';
  271. { only qword needs the unsigned code, the
  272. signed code is also used for currency }
  273. if is_signed(resultdef) then
  274. procname := procname + 'longint'
  275. else
  276. procname := procname + 'dword';
  277. result := ccallnode.createintern(procname,ccallparanode.create(left,
  278. ccallparanode.create(right,nil)));
  279. left := nil;
  280. right := nil;
  281. firstpass(result);
  282. end;
  283. {$else cpuneedsdiv32helper}
  284. begin
  285. result:=nil;
  286. end;
  287. {$endif cpuneedsdiv32helper}
  288. {$ifndef cpu64bitalu}
  289. function tmoddivnode.first_moddiv64bitint: tnode;
  290. var
  291. procname: string[31];
  292. begin
  293. result := nil;
  294. { when currency is used set the result of the
  295. parameters to s64bit, so they are not converted }
  296. if is_currency(resultdef) then
  297. begin
  298. left.resultdef:=s64inttype;
  299. right.resultdef:=s64inttype;
  300. end;
  301. { otherwise create a call to a helper }
  302. if nodetype = divn then
  303. procname := 'fpc_div_'
  304. else
  305. procname := 'fpc_mod_';
  306. { only qword needs the unsigned code, the
  307. signed code is also used for currency }
  308. if is_signed(resultdef) then
  309. procname := procname + 'int64'
  310. else
  311. procname := procname + 'qword';
  312. result := ccallnode.createintern(procname,ccallparanode.create(left,
  313. ccallparanode.create(right,nil)));
  314. left := nil;
  315. right := nil;
  316. firstpass(result);
  317. end;
  318. {$endif not cpu64bitalu}
  319. function tmoddivnode.firstoptimize: tnode;
  320. var
  321. power{,shiftval} : longint;
  322. newtype: tnodetype;
  323. begin
  324. result := nil;
  325. { divide/mod a number by a constant which is a power of 2? }
  326. if (cs_opt_peephole in current_settings.optimizerswitches) and
  327. (right.nodetype = ordconstn) and
  328. { ((nodetype = divn) or
  329. not is_signed(resultdef)) and}
  330. (not is_signed(resultdef)) and
  331. ispowerof2(tordconstnode(right).value,power) then
  332. begin
  333. if nodetype = divn then
  334. begin
  335. (*
  336. if is_signed(resultdef) then
  337. begin
  338. if is_64bitint(left.resultdef) then
  339. if not (cs_opt_size in current_settings.optimizerswitches) then
  340. shiftval := 63
  341. else
  342. { the shift code is a lot bigger than the call to }
  343. { the divide helper }
  344. exit
  345. else
  346. shiftval := 31;
  347. { we reuse left twice, so create once a copy of it }
  348. { !!! if left is a call is -> call gets executed twice }
  349. left := caddnode.create(addn,left,
  350. caddnode.create(andn,
  351. cshlshrnode.create(sarn,left.getcopy,
  352. cordconstnode.create(shiftval,sinttype,false)),
  353. cordconstnode.create(tordconstnode(right).value-1,
  354. right.resultdef,false)));
  355. newtype := sarn;
  356. end
  357. else
  358. *)
  359. newtype := shrn;
  360. tordconstnode(right).value := power;
  361. result := cshlshrnode.create(newtype,left,right)
  362. end
  363. else
  364. begin
  365. dec(tordconstnode(right).value.uvalue);
  366. result := caddnode.create(andn,left,right);
  367. end;
  368. { left and right are reused }
  369. left := nil;
  370. right := nil;
  371. firstpass(result);
  372. exit;
  373. end;
  374. end;
  375. function tmoddivnode.pass_1 : tnode;
  376. begin
  377. result:=nil;
  378. firstpass(left);
  379. firstpass(right);
  380. if codegenerror then
  381. exit;
  382. { Try to optimize mod/div }
  383. result := firstoptimize;
  384. if assigned(result) then
  385. exit;
  386. {$ifndef cpu64bitalu}
  387. { 64bit }
  388. if (left.resultdef.typ=orddef) and
  389. (right.resultdef.typ=orddef) and
  390. (is_64bitint(left.resultdef) or is_64bitint(right.resultdef)) then
  391. begin
  392. result := first_moddiv64bitint;
  393. if assigned(result) then
  394. exit;
  395. expectloc:=LOC_REGISTER;
  396. end
  397. else
  398. {$endif not cpu64bitalu}
  399. begin
  400. result := first_moddivint;
  401. if assigned(result) then
  402. exit;
  403. end;
  404. expectloc:=LOC_REGISTER;
  405. end;
  406. {****************************************************************************
  407. TSHLSHRNODE
  408. ****************************************************************************}
  409. function tshlshrnode.simplify(forinline : boolean):tnode;
  410. begin
  411. result:=nil;
  412. { constant folding }
  413. if is_constintnode(left) and is_constintnode(right) then
  414. begin
  415. case nodetype of
  416. shrn:
  417. result:=create_simplified_ord_const(tordconstnode(left).value shr tordconstnode(right).value,resultdef,forinline);
  418. shln:
  419. result:=create_simplified_ord_const(tordconstnode(left).value shl tordconstnode(right).value,resultdef,forinline);
  420. end;
  421. end;
  422. end;
  423. function tshlshrnode.pass_typecheck:tnode;
  424. var
  425. t : tnode;
  426. {$ifdef cpunodefaultint}
  427. nd : tdef;
  428. {$endif cpunodefaultint}
  429. begin
  430. result:=nil;
  431. typecheckpass(left);
  432. typecheckpass(right);
  433. set_varstate(right,vs_read,[vsf_must_be_valid]);
  434. set_varstate(left,vs_read,[vsf_must_be_valid]);
  435. if codegenerror then
  436. exit;
  437. { tp procvar support }
  438. maybe_call_procvar(left,true);
  439. maybe_call_procvar(right,true);
  440. result:=simplify(false);
  441. if assigned(result) then
  442. exit;
  443. { allow operator overloading }
  444. t:=self;
  445. if isbinaryoverloaded(t) then
  446. begin
  447. result:=t;
  448. exit;
  449. end;
  450. {$ifdef cpunodefaultint}
  451. { for small cpus we use the smallest common type }
  452. if (left.resultdef.typ=orddef) and (right.resultdef.typ=orddef) then
  453. nd:=get_common_intdef(torddef(left.resultdef),torddef(right.resultdef),false)
  454. else
  455. nd:=s32inttype;
  456. {$endif cpunodefaultint}
  457. { calculations for ordinals < 32 bit have to be done in
  458. 32 bit for backwards compatibility. That way 'shl 33' is
  459. the same as 'shl 1'. It's ugly but compatible with delphi/tp/gcc }
  460. if (not is_64bit(left.resultdef)) and
  461. (torddef(left.resultdef).ordtype<>u32bit) then
  462. begin
  463. { keep singness of orignal type }
  464. if is_signed(left.resultdef) then
  465. {$ifdef cpunodefaultint}
  466. inserttypeconv(left,nd)
  467. {$else cpunodefaultint}
  468. inserttypeconv(left,s32inttype)
  469. {$endif cpunodefaultint}
  470. else
  471. begin
  472. {$ifdef cpunodefaultint}
  473. inserttypeconv(left,nd)
  474. {$else cpunodefaultint}
  475. inserttypeconv(left,u32inttype);
  476. {$endif cpunodefaultint}
  477. end
  478. end;
  479. {$ifdef cpunodefaultint}
  480. inserttypeconv(right,nd);
  481. {$else cpunodefaultint}
  482. inserttypeconv(right,sinttype);
  483. {$endif cpunodefaultint}
  484. resultdef:=left.resultdef;
  485. end;
  486. {$ifndef cpu64bitalu}
  487. function tshlshrnode.first_shlshr64bitint: tnode;
  488. var
  489. procname: string[31];
  490. begin
  491. result := nil;
  492. { Normally already done below, but called again,
  493. just in case it is called directly }
  494. firstpass(left);
  495. { otherwise create a call to a helper }
  496. if is_signed(left.resultdef) then
  497. procname:='int64'
  498. else
  499. procname:='qword';
  500. if nodetype = shln then
  501. procname := 'fpc_shl_'+procname
  502. else
  503. procname := 'fpc_shr_'+procname;
  504. { this order of parameters works at least for the arm,
  505. however it should work for any calling conventions (FK) }
  506. result := ccallnode.createintern(procname,ccallparanode.create(right,
  507. ccallparanode.create(left,nil)));
  508. left := nil;
  509. right := nil;
  510. firstpass(result);
  511. end;
  512. {$endif not cpu64bitalu}
  513. function tshlshrnode.pass_1 : tnode;
  514. var
  515. regs : longint;
  516. begin
  517. result:=nil;
  518. firstpass(left);
  519. firstpass(right);
  520. if codegenerror then
  521. exit;
  522. {$ifndef cpu64bitalu}
  523. { 64 bit ints have their own shift handling }
  524. if is_64bit(left.resultdef) then
  525. begin
  526. result := first_shlshr64bitint;
  527. if assigned(result) then
  528. exit;
  529. regs:=2;
  530. end
  531. else
  532. {$endif not cpu64bitalu}
  533. begin
  534. regs:=1
  535. end;
  536. if (right.nodetype<>ordconstn) then
  537. inc(regs);
  538. expectloc:=LOC_REGISTER;
  539. end;
  540. {****************************************************************************
  541. TUNARYMINUSNODE
  542. ****************************************************************************}
  543. constructor tunaryminusnode.create(expr : tnode);
  544. begin
  545. inherited create(unaryminusn,expr);
  546. end;
  547. function tunaryminusnode.simplify(forinline : boolean):tnode;
  548. begin
  549. result:=nil;
  550. { constant folding }
  551. if is_constintnode(left) then
  552. begin
  553. result:=create_simplified_ord_const(-tordconstnode(left).value,resultdef,forinline);
  554. exit;
  555. end;
  556. if is_constrealnode(left) then
  557. begin
  558. trealconstnode(left).value_real:=-trealconstnode(left).value_real;
  559. trealconstnode(left).value_currency:=-trealconstnode(left).value_currency;
  560. result:=left;
  561. left:=nil;
  562. exit;
  563. end;
  564. end;
  565. function tunaryminusnode.pass_typecheck : tnode;
  566. var
  567. t : tnode;
  568. begin
  569. result:=nil;
  570. typecheckpass(left);
  571. set_varstate(left,vs_read,[vsf_must_be_valid]);
  572. if codegenerror then
  573. exit;
  574. result:=simplify(false);
  575. if assigned(result) then
  576. exit;
  577. resultdef:=left.resultdef;
  578. if (left.resultdef.typ=floatdef) or
  579. is_currency(left.resultdef) then
  580. begin
  581. end
  582. {$ifdef SUPPORT_MMX}
  583. else if (cs_mmx in current_settings.localswitches) and
  584. is_mmx_able_array(left.resultdef) then
  585. begin
  586. { if saturation is on, left.resultdef isn't
  587. "mmx able" (FK)
  588. if (cs_mmx_saturation in current_settings.localswitches^) and
  589. (torddef(tarraydef(resultdef).definition).typ in
  590. [s32bit,u32bit]) then
  591. CGMessage(type_e_mismatch);
  592. }
  593. end
  594. {$endif SUPPORT_MMX}
  595. {$ifndef cpu64bitaddr}
  596. else if is_64bit(left.resultdef) then
  597. begin
  598. inserttypeconv(left,s64inttype);
  599. resultdef:=left.resultdef
  600. end
  601. {$endif not cpu64bitaddr}
  602. else if (left.resultdef.typ=orddef) then
  603. begin
  604. inserttypeconv(left,sinttype);
  605. resultdef:=left.resultdef
  606. end
  607. else
  608. begin
  609. { allow operator overloading }
  610. t:=self;
  611. if isunaryoverloaded(t) then
  612. begin
  613. result:=t;
  614. exit;
  615. end;
  616. CGMessage(type_e_mismatch);
  617. end;
  618. end;
  619. { generic code }
  620. { overridden by: }
  621. { i386 }
  622. function tunaryminusnode.pass_1 : tnode;
  623. var
  624. procname: string[31];
  625. fdef : tdef;
  626. begin
  627. result:=nil;
  628. firstpass(left);
  629. if codegenerror then
  630. exit;
  631. if (cs_fp_emulation in current_settings.moduleswitches) and (left.resultdef.typ=floatdef) then
  632. begin
  633. if not(target_info.system in systems_wince) then
  634. begin
  635. case tfloatdef(resultdef).floattype of
  636. s32real:
  637. begin
  638. procname:='float32_sub';
  639. fdef:=search_system_type('FLOAT32REC').typedef;
  640. end;
  641. s64real:
  642. begin
  643. procname:='float64_sub';
  644. fdef:=search_system_type('FLOAT64').typedef;
  645. end;
  646. {!!! not yet implemented
  647. s128real:
  648. }
  649. else
  650. internalerror(2005082801);
  651. end;
  652. result:=ctypeconvnode.create_internal(ccallnode.createintern(procname,ccallparanode.create(
  653. ctypeconvnode.create_internal(left,fDef),
  654. ccallparanode.create(ctypeconvnode.create_internal(crealconstnode.create(0,resultdef),fdef),nil))),resultdef);
  655. end
  656. else
  657. begin
  658. case tfloatdef(resultdef).floattype of
  659. s32real:
  660. procname:='NEGS';
  661. s64real:
  662. procname:='NEGD';
  663. {!!! not yet implemented
  664. s128real:
  665. }
  666. else
  667. internalerror(2005082802);
  668. end;
  669. result:=ccallnode.createintern(procname,ccallparanode.create(left,nil));
  670. end;
  671. left:=nil;
  672. end
  673. else
  674. begin
  675. if (left.resultdef.typ=floatdef) then
  676. expectloc:=LOC_FPUREGISTER
  677. {$ifdef SUPPORT_MMX}
  678. else if (cs_mmx in current_settings.localswitches) and
  679. is_mmx_able_array(left.resultdef) then
  680. expectloc:=LOC_MMXREGISTER
  681. {$endif SUPPORT_MMX}
  682. else if (left.resultdef.typ=orddef) then
  683. expectloc:=LOC_REGISTER;
  684. end;
  685. end;
  686. {****************************************************************************
  687. TUNARYPLUSNODE
  688. ****************************************************************************}
  689. constructor tunaryplusnode.create(expr: tnode);
  690. begin
  691. inherited create(unaryplusn,expr);
  692. end;
  693. function tunaryplusnode.pass_1: tnode;
  694. begin
  695. result:=nil;
  696. { can never happen because all the conversions happen
  697. in pass_typecheck }
  698. internalerror(201012250);
  699. end;
  700. function tunaryplusnode.pass_typecheck: tnode;
  701. var
  702. t:tnode;
  703. begin
  704. result:=nil;
  705. typecheckpass(left);
  706. set_varstate(left,vs_read,[vsf_must_be_valid]);
  707. if codegenerror then
  708. exit;
  709. if is_constintnode(left) or
  710. is_constrealnode(left) or
  711. (left.resultdef.typ=floatdef) or
  712. is_currency(left.resultdef)
  713. {$ifdef SUPPORT_MMX}
  714. or ((cs_mmx in current_settings.localswitches) and
  715. is_mmx_able_array(left.resultdef))
  716. {$endif SUPPORT_MMX}
  717. then
  718. begin
  719. result:=left;
  720. left:=nil;
  721. end
  722. {$ifndef cpu64bitaddr}
  723. else if is_64bit(left.resultdef) then
  724. begin
  725. inserttypeconv(left,s64inttype);
  726. result:=left;
  727. left:=nil;
  728. end
  729. {$endif not cpu64bitaddr}
  730. else if (left.resultdef.typ=orddef) then
  731. begin
  732. inserttypeconv(left,sinttype);
  733. result:=left;
  734. left:=nil;
  735. end
  736. else
  737. begin
  738. { allow operator overloading }
  739. t:=self;
  740. if isunaryoverloaded(t) then
  741. begin
  742. result:=t;
  743. exit;
  744. end;
  745. CGMessage(type_e_mismatch);
  746. end;
  747. end;
  748. {****************************************************************************
  749. TNOTNODE
  750. ****************************************************************************}
  751. const
  752. boolean_reverse:array[ltn..unequaln] of Tnodetype=(
  753. gten,gtn,lten,ltn,unequaln,equaln
  754. );
  755. constructor tnotnode.create(expr : tnode);
  756. begin
  757. inherited create(notn,expr);
  758. end;
  759. function tnotnode.simplify(forinline : boolean):tnode;
  760. var
  761. v : tconstexprint;
  762. t : tnode;
  763. def : tdef;
  764. begin
  765. result:=nil;
  766. { Try optmimizing ourself away }
  767. if left.nodetype=notn then
  768. begin
  769. { Double not. Remove both }
  770. result:=Tnotnode(left).left;
  771. tnotnode(left).left:=nil;
  772. exit;
  773. end;
  774. if (left.nodetype in [ltn,lten,equaln,unequaln,gtn,gten]) then
  775. begin
  776. { Not of boolean expression. Turn around the operator and remove
  777. the not. This is not allowed for sets with the gten/lten,
  778. because there is no ltn/gtn support }
  779. if (taddnode(left).left.resultdef.typ<>setdef) or
  780. (left.nodetype in [equaln,unequaln]) then
  781. begin
  782. result:=left;
  783. left.nodetype:=boolean_reverse[left.nodetype];
  784. left:=nil;
  785. exit;
  786. end;
  787. end;
  788. { constant folding }
  789. if (left.nodetype=ordconstn) then
  790. begin
  791. v:=tordconstnode(left).value;
  792. def:=left.resultdef;
  793. case torddef(left.resultdef).ordtype of
  794. pasbool8,
  795. pasbool16,
  796. pasbool32,
  797. pasbool64,
  798. bool8bit,
  799. bool16bit,
  800. bool32bit,
  801. bool64bit:
  802. begin
  803. v:=byte(not(boolean(int64(v))));
  804. if is_cbool(left.resultdef) then
  805. v:=-v;
  806. end;
  807. uchar,
  808. uwidechar,
  809. u8bit,
  810. s8bit,
  811. u16bit,
  812. s16bit,
  813. s32bit,
  814. {$ifdef cpu64bitaddr}
  815. u32bit,
  816. {$endif cpu64bitaddr}
  817. s64bit:
  818. begin
  819. v:=int64(not int64(v));
  820. if (torddef(left.resultdef).ordtype<>s64bit) then
  821. def:=sinttype
  822. else
  823. def:=s64inttype;
  824. end;
  825. {$ifndef cpu64bitaddr}
  826. u32bit,
  827. {$endif not cpu64bitaddr}
  828. u64bit :
  829. begin
  830. { Delphi-compatible: not dword = dword (not word = longint) }
  831. { Extension: not qword = qword }
  832. v:=qword(not qword(v));
  833. { will be truncated by the ordconstnode for u32bit }
  834. end;
  835. else
  836. CGMessage(type_e_mismatch);
  837. end;
  838. if not forinline then
  839. t:=cordconstnode.create(v,def,false)
  840. else
  841. t:=create_simplified_ord_const(v,resultdef,true);
  842. result:=t;
  843. exit;
  844. end;
  845. end;
  846. function tnotnode.pass_typecheck : tnode;
  847. var
  848. t : tnode;
  849. begin
  850. result:=nil;
  851. typecheckpass(left);
  852. set_varstate(left,vs_read,[vsf_must_be_valid]);
  853. if codegenerror then
  854. exit;
  855. { tp procvar support }
  856. maybe_call_procvar(left,true);
  857. resultdef:=left.resultdef;
  858. result:=simplify(false);
  859. if assigned(result) then
  860. exit;
  861. if is_boolean(resultdef) then
  862. begin
  863. end
  864. else
  865. {$ifdef SUPPORT_MMX}
  866. if (cs_mmx in current_settings.localswitches) and
  867. is_mmx_able_array(left.resultdef) then
  868. begin
  869. end
  870. else
  871. {$endif SUPPORT_MMX}
  872. {$ifndef cpu64bitaddr}
  873. if is_64bitint(left.resultdef) then
  874. begin
  875. end
  876. else
  877. {$endif not cpu64bitaddr}
  878. if is_integer(left.resultdef) then
  879. begin
  880. end
  881. else
  882. begin
  883. { allow operator overloading }
  884. t:=self;
  885. if isunaryoverloaded(t) then
  886. begin
  887. result:=t;
  888. exit;
  889. end;
  890. CGMessage(type_e_mismatch);
  891. end;
  892. end;
  893. function tnotnode.pass_1 : tnode;
  894. begin
  895. result:=nil;
  896. firstpass(left);
  897. if codegenerror then
  898. exit;
  899. expectloc:=left.expectloc;
  900. if is_boolean(resultdef) then
  901. begin
  902. if (expectloc in [LOC_REFERENCE,LOC_CREFERENCE,LOC_CREGISTER]) then
  903. expectloc:=LOC_REGISTER;
  904. { before loading it into flags we need to load it into
  905. a register thus 1 register is need PM }
  906. {$ifdef cpuflags}
  907. if left.expectloc<>LOC_JUMP then
  908. expectloc:=LOC_FLAGS;
  909. {$endif def cpuflags}
  910. end
  911. else
  912. {$ifdef SUPPORT_MMX}
  913. if (cs_mmx in current_settings.localswitches) and
  914. is_mmx_able_array(left.resultdef) then
  915. expectloc:=LOC_MMXREGISTER
  916. else
  917. {$endif SUPPORT_MMX}
  918. {$ifndef cpu64bitalu}
  919. if is_64bit(left.resultdef) then
  920. begin
  921. if (expectloc in [LOC_REFERENCE,LOC_CREFERENCE,LOC_CREGISTER]) then
  922. expectloc:=LOC_REGISTER;
  923. end
  924. else
  925. {$endif not cpu64bitalu}
  926. if is_integer(left.resultdef) then
  927. expectloc:=LOC_REGISTER;
  928. end;
  929. {$ifdef state_tracking}
  930. function Tnotnode.track_state_pass(exec_known:boolean):boolean;
  931. begin
  932. track_state_pass:=true;
  933. if left.track_state_pass(exec_known) then
  934. begin
  935. left.resultdef:=nil;
  936. do_typecheckpass(left);
  937. end;
  938. end;
  939. {$endif}
  940. end.