sfttst.pp 19 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827
  1. {****************************************************************}
  2. { Softfloat module testsuit }
  3. {****************************************************************}
  4. { Copyright (c) 2002 Carl Eric Codere }
  5. {****************************************************************}
  6. program sfttst;
  7. uses softfpu;
  8. {$E+}
  9. procedure fail;
  10. begin
  11. WriteLn('Failed!');
  12. halt(1);
  13. end;
  14. function singletofloat32(r: single):float32;
  15. var
  16. _result: float32;
  17. begin
  18. move(r,_result, sizeof(r));
  19. singletofloat32 := _result;
  20. end;
  21. function float32tosingle(r: float32): single;
  22. var
  23. _result : single;
  24. begin
  25. move(r, _result, sizeof(r));
  26. float32tosingle := _result;
  27. end;
  28. function doubletofloat64(r: double):float64;
  29. var
  30. _result: float64;
  31. begin
  32. move(r,_result, sizeof(r));
  33. doubletofloat64 := _result;
  34. end;
  35. function float64todouble(r: float64): double;
  36. var
  37. _result : double;
  38. begin
  39. move(r, _result, sizeof(r));
  40. float64todouble := _result;
  41. end;
  42. {******************************************************************************}
  43. {* single arithmetic *}
  44. {******************************************************************************}
  45. Procedure float32TestSub;
  46. var
  47. i : single;
  48. j : single;
  49. val1,val2 : float32;
  50. result : boolean;
  51. Begin
  52. Write('single - single test...');
  53. result := true;
  54. i:=99.9;
  55. j:=10.0;
  56. val1:=singletofloat32(i);
  57. val2:=singletofloat32(j);
  58. { i:=i-j }
  59. val1:= float32_sub(val1,val2);
  60. i:=float32tosingle(val1);
  61. j:=float32tosingle(val2);
  62. if trunc(i) <> trunc(89.9) then
  63. result := false;
  64. WriteLn('Result (89.9) :',i);
  65. val1:=singletofloat32(i);
  66. val2:=singletofloat32(j);
  67. { i:=j-i }
  68. val1:= float32_sub(val2,val1);
  69. i:=float32tosingle(val1);
  70. j:=float32tosingle(val2);
  71. if trunc(i) <> trunc(-79.9) then
  72. result := false;
  73. WriteLn('Result (-79.9) :',i);
  74. val1:=singletofloat32(j);
  75. val2:=singletofloat32(10.0);
  76. { j:=j-10.0 }
  77. val1:= float32_sub(val1,val2);
  78. j:=float32tosingle(val1);
  79. if j <> 0.0 then
  80. result := false;
  81. WriteLn('Result (0.0) :',j);
  82. if not result then
  83. Fail
  84. else
  85. WriteLn('Success.');
  86. end;
  87. procedure float32TestAdd;
  88. var
  89. i : single;
  90. j : single;
  91. result : boolean;
  92. val1, val2 : float32;
  93. Begin
  94. WriteLn('single + single test...');
  95. result := true;
  96. i:= 9;
  97. { i:=i+1.5;}
  98. val1:=float32_add(singletofloat32(i),singletofloat32(1.5));
  99. i:=float32tosingle(val1);
  100. if trunc(i) <> trunc(10.5) then
  101. result := false;
  102. WriteLn('Result (10.5) :',i);
  103. i := 326788.12345;
  104. j := 100.0;
  105. { i := i + j + 12.5;}
  106. val1 := singletofloat32(i);
  107. val2 := singletofloat32(j);
  108. val1:=float32_add(val1,val2); { i:=i+j }
  109. val1:=float32_add(val1,singletofloat32(12.5));
  110. i:=float32tosingle(val1);
  111. if trunc(i) <> trunc(326900.12345) then
  112. result := false;
  113. WriteLn('Result (326900.12345) :',i);
  114. if not result then
  115. Fail
  116. else
  117. WriteLn('Success.');
  118. end;
  119. procedure float32testmul;
  120. var
  121. i : single;
  122. j : single;
  123. result : boolean;
  124. val1 : float32;
  125. begin
  126. WriteLn('single * single test...');
  127. result := true;
  128. i:= 21111.0;
  129. j:= 11.1;
  130. { i := i * j * i; }
  131. val1:=float32_mul(singletofloat32(i),singletofloat32(j));
  132. i:=float32tosingle(val1);
  133. if trunc(i) <> trunc(234332.1) then
  134. result := false;
  135. WriteLn('Result (234332.1) :',i);
  136. i := 10.0;
  137. j := -12.0;
  138. { i := i * j * 10.0;}
  139. val1:=float32_mul(float32_mul(singletofloat32(i),singletofloat32(j)),singletofloat32(10.0));
  140. i:=float32tosingle(val1);
  141. if trunc(i) <> trunc(-1200.0) then
  142. result := false;
  143. WriteLn('Result (-1200.0) :',i);
  144. if not result then
  145. Fail
  146. else
  147. WriteLn('Success.');
  148. end;
  149. Procedure float32TestDiv;
  150. var
  151. i : single;
  152. j : single;
  153. val1 : float32;
  154. result : boolean;
  155. Begin
  156. result := true;
  157. WriteLn('single / single test...');
  158. i:=-99.9;
  159. j:=10.0;
  160. { i:=i / j; }
  161. val1:=float32_div(singletofloat32(i),singletofloat32(j));
  162. i:=float32tosingle(val1);
  163. if trunc(i) <> trunc(-9.9) then
  164. result := false;
  165. WriteLn('Result (-9.9) :',i);
  166. {i:=j / i;}
  167. val1:=float32_div(singletofloat32(j),singletofloat32(i));
  168. i:=float32tosingle(val1);
  169. if trunc(i) <> trunc(-1.01) then
  170. result := false;
  171. WriteLN('Result (-1.01) :',i);
  172. { j:=i / 10.0; }
  173. val1:=float32_div(singletofloat32(i),singletofloat32(10.0));
  174. j:=float32tosingle(val1);
  175. if trunc(j) <> trunc(-0.1001) then
  176. result := false;
  177. WriteLn('Result (-0.1001) :',j);
  178. if not result then
  179. Fail
  180. else
  181. WriteLn('Success.');
  182. end;
  183. procedure float32testequal;
  184. var
  185. i : single;
  186. j : single;
  187. result : boolean;
  188. val1,val2 : float32;
  189. begin
  190. result := true;
  191. Write('single = single test...');
  192. i := 1000.0;
  193. j := 1000.0;
  194. val1 := singletofloat32(i);
  195. val2 := singletofloat32(j);
  196. if (float32_eq(val1,val2)=0) then
  197. result := false;
  198. i := -112345.1;
  199. j := -112345.1;
  200. val1 := singletofloat32(i);
  201. val2 := singletofloat32(j);
  202. if (float32_eq(val1,val2)=0) then
  203. result := false;
  204. i := 4502020.1125E+03;
  205. j := 4502020.1125E+03;
  206. val1 := singletofloat32(i);
  207. val2 := singletofloat32(j);
  208. if (float32_eq(val1,val2)=0) then
  209. result := false;
  210. i := -4502028.1125E+03;
  211. j := -4502028.1125E+03;
  212. val1 := singletofloat32(i);
  213. val2 := singletofloat32(j);
  214. if (float32_eq(val1,val2)=0) then
  215. result := false;
  216. i := -4502030.1125E+03;
  217. j := -4502028.1125E+03;
  218. val1 := singletofloat32(i);
  219. val2 := singletofloat32(j);
  220. if (float32_eq(val1,val2)<>0) then
  221. result := false;
  222. if not result then
  223. Fail
  224. else
  225. WriteLn('Success.');
  226. end;
  227. procedure float32testle;
  228. var
  229. i : single;
  230. j : single;
  231. result : boolean;
  232. val1,val2: float32;
  233. begin
  234. result := true;
  235. Write('single <= single test...');
  236. i := 1000.0;
  237. j := 1000.0;
  238. val1 := singletofloat32(i);
  239. val2 := singletofloat32(j);
  240. if (float32_le(val1,val2)=0) then
  241. result := false;
  242. i := 10000.0;
  243. j := 999.0;
  244. val1 := singletofloat32(i);
  245. val2 := singletofloat32(j);
  246. if (float32_le(val2,val1)=0) then
  247. result := false;
  248. i := -10000.0;
  249. j := -999.0;
  250. val1 := singletofloat32(i);
  251. val2 := singletofloat32(j);
  252. if (float32_le(val2,val1)<>0) then
  253. result := false;
  254. if not result then
  255. Fail
  256. else
  257. WriteLn('Success.');
  258. end;
  259. procedure float32testlt;
  260. var
  261. i : single;
  262. j : single;
  263. val1,val2 : float32;
  264. result : boolean;
  265. begin
  266. result := true;
  267. Write('single < single test...');
  268. i := 1000.0;
  269. j := 1000.0;
  270. val1 := singletofloat32(i);
  271. val2 := singletofloat32(j);
  272. if (float32_lt(val1,val2)<>0) then
  273. result := false;
  274. i := 999.0;
  275. j := 1000.0;
  276. val1 := singletofloat32(i);
  277. val2 := singletofloat32(j);
  278. if (float32_lt(val1,val2)=0) then
  279. result := false;
  280. i := -10000.0;
  281. j := -999.0;
  282. val1 := singletofloat32(i);
  283. val2 := singletofloat32(j);
  284. if (float32_lt(val2,val1)<>0) then
  285. result := false;
  286. if not result then
  287. Fail
  288. else
  289. WriteLn('Success.');
  290. end;
  291. procedure Float32TestInt;
  292. var
  293. _result : longint;
  294. result : boolean;
  295. begin
  296. result := true;
  297. Write('Single to Longint test...');
  298. _result:=float32_to_int32(singletofloat32(-12.12345));
  299. if _result <> -12 then
  300. result := false;
  301. _result:=float32_to_int32(singletofloat32(12.52345));
  302. if _result <> 13 then
  303. result := false;
  304. _result:=float32_to_int32(singletofloat32(-0.01));
  305. if _result <> 0 then
  306. result := false;
  307. if not result then
  308. Fail
  309. else
  310. WriteLn('Success.');
  311. end;
  312. {Procedure int32_to_float32( a: int32; var c: float32 ); }
  313. procedure IntTestFloat32;
  314. var
  315. result : boolean;
  316. val1 : float32;
  317. begin
  318. result := true;
  319. Write('Longint to single test...');
  320. val1:=int32_to_float32($8000);
  321. if float32tosingle(val1) <> $8000 then
  322. result := false;
  323. val1:=int32_to_float32(-1);
  324. if float32tosingle(val1) <> -1 then
  325. result := false;
  326. val1:=int32_to_float32(0);
  327. if (float32tosingle(val1)) <> 0.0 then
  328. result := false;
  329. val1:=int32_to_float32(-217000000);
  330. if float32tosingle(val1) <> -217000000 then
  331. result := false;
  332. if not result then
  333. Fail
  334. else
  335. WriteLn('Success.');
  336. end;
  337. {******************************************************************************}
  338. {* double arithmetic *}
  339. {******************************************************************************}
  340. Procedure float64TestSub;
  341. var
  342. i : double;
  343. j : double;
  344. val1,val2 : float64;
  345. result : boolean;
  346. Begin
  347. Write('Double - Double test...');
  348. result := true;
  349. i:=99.9;
  350. j:=10.0;
  351. val1:=doubletofloat64(i);
  352. val2:=doubletofloat64(j);
  353. { i:=i-j }
  354. float64_sub(val1,val2,val1);
  355. i:=float64todouble(val1);
  356. j:=float64todouble(val2);
  357. if trunc(i) <> trunc(89.9) then
  358. result := false;
  359. WriteLn('Result (89.9) :',i);
  360. val1:=doubletofloat64(i);
  361. val2:=doubletofloat64(j);
  362. { i:=j-i }
  363. float64_sub(val2,val1,val1);
  364. i:=float64todouble(val1);
  365. j:=float64todouble(val2);
  366. if trunc(i) <> trunc(-79.9) then
  367. result := false;
  368. WriteLn('Result (-79.9) :',i);
  369. val1:=doubletofloat64(j);
  370. val2:=doubletofloat64(10.0);
  371. { j:=j-10.0 }
  372. float64_sub(val1,val2,val1);
  373. j:=float64todouble(val1);
  374. if j <> 0.0 then
  375. result := false;
  376. WriteLn('Result (0.0) :',j);
  377. if not result then
  378. Fail
  379. else
  380. WriteLn('Success.');
  381. end;
  382. procedure float64TestAdd;
  383. var
  384. i : double;
  385. j : double;
  386. result : boolean;
  387. val1, val2 : float64;
  388. Begin
  389. WriteLn('Double + Double test...');
  390. result := true;
  391. i:= 9;
  392. { i:=i+1.5;}
  393. float64_add(doubletofloat64(i),doubletofloat64(1.5),val1);
  394. i:=float64todouble(val1);
  395. if trunc(i) <> trunc(10.5) then
  396. result := false;
  397. WriteLn('Result (10.5) :',i);
  398. i := 326788.12345;
  399. j := 100.0;
  400. { i := i + j + 12.5;}
  401. val1 := doubletofloat64(i);
  402. val2 := doubletofloat64(j);
  403. float64_add(val1,val2,val1); { i:=i+j }
  404. float64_add(val1,doubletofloat64(12.5),val1);
  405. i:=float64todouble(val1);
  406. if trunc(i) <> trunc(326900.12345) then
  407. result := false;
  408. WriteLn('Result (326900.12345) :',i);
  409. if not result then
  410. Fail
  411. else
  412. WriteLn('Success.');
  413. end;
  414. procedure float64testmul;
  415. var
  416. i : double;
  417. j : double;
  418. result : boolean;
  419. val1 : float64;
  420. begin
  421. WriteLn('Double * Double test...');
  422. result := true;
  423. i:= 21111.0;
  424. j:= 11.1;
  425. { i := i * j * i; }
  426. float64_mul(doubletofloat64(i),doubletofloat64(j),val1);
  427. i:=float64todouble(val1);
  428. if trunc(i) <> trunc(234332.1) then
  429. result := false;
  430. WriteLn('Result (234332.1) :',i);
  431. i := 10.0;
  432. j := -12.0;
  433. { i := i * j * 10.0;}
  434. float64_mul(doubletofloat64(i),doubletofloat64(j),val1);
  435. float64_mul(val1,doubletofloat64(10.0),val1);
  436. i:=float64todouble(val1);
  437. if trunc(i) <> trunc(-1200.0) then
  438. result := false;
  439. WriteLn('Result (-1200.0) :',i);
  440. if not result then
  441. Fail
  442. else
  443. WriteLn('Success.');
  444. end;
  445. Procedure float64TestDiv;
  446. var
  447. i : double;
  448. j : double;
  449. val1 : float64;
  450. result : boolean;
  451. Begin
  452. result := true;
  453. WriteLn('Double / Double test...');
  454. i:=-99.9;
  455. j:=10.0;
  456. { i:=i / j; }
  457. float64_div(doubletofloat64(i),doubletofloat64(j),val1);
  458. i:=float64todouble(val1);
  459. if trunc(i) <> trunc(-9.9) then
  460. result := false;
  461. WriteLn('Result (-9.9) :',i);
  462. {i:=j / i;}
  463. float64_div(doubletofloat64(j),doubletofloat64(i),val1);
  464. i:=float64todouble(val1);
  465. if trunc(i) <> trunc(-1.01) then
  466. result := false;
  467. WriteLN('Result (-1.01) :',i);
  468. { j:=i / 10.0; }
  469. float64_div(doubletofloat64(i),doubletofloat64(10.0),val1);
  470. j:=float64todouble(val1);
  471. if trunc(j) <> trunc(-0.1001) then
  472. result := false;
  473. WriteLn('Result (-0.1001) :',j);
  474. if not result then
  475. Fail
  476. else
  477. WriteLn('Success.');
  478. end;
  479. procedure float64testequal;
  480. var
  481. i : double;
  482. j : double;
  483. result : boolean;
  484. val1,val2 : float64;
  485. begin
  486. result := true;
  487. Write('Double = Double test...');
  488. i := 1000.0;
  489. j := 1000.0;
  490. val1 := doubletofloat64(i);
  491. val2 := doubletofloat64(j);
  492. if (float64_eq(val1,val2)=0) then
  493. result := false;
  494. i := -112345.1;
  495. j := -112345.1;
  496. val1 := doubletofloat64(i);
  497. val2 := doubletofloat64(j);
  498. if (float64_eq(val1,val2)=0) then
  499. result := false;
  500. i := 4502020.1125E+03;
  501. j := 4502020.1125E+03;
  502. val1 := doubletofloat64(i);
  503. val2 := doubletofloat64(j);
  504. if (float64_eq(val1,val2)=0) then
  505. result := false;
  506. i := -4502028.1125E+03;
  507. j := -4502028.1125E+03;
  508. val1 := doubletofloat64(i);
  509. val2 := doubletofloat64(j);
  510. if (float64_eq(val1,val2)=0) then
  511. result := false;
  512. i := -4502030.1125E+03;
  513. j := -4502028.1125E+03;
  514. val1 := doubletofloat64(i);
  515. val2 := doubletofloat64(j);
  516. if (float64_eq(val1,val2)<>0) then
  517. result := false;
  518. if not result then
  519. Fail
  520. else
  521. WriteLn('Success.');
  522. end;
  523. procedure float64testle;
  524. var
  525. i : double;
  526. j : double;
  527. result : boolean;
  528. val1,val2: float64;
  529. begin
  530. result := true;
  531. Write('Double <= Double test...');
  532. i := 1000.0;
  533. j := 1000.0;
  534. val1 := doubletofloat64(i);
  535. val2 := doubletofloat64(j);
  536. if (float64_le(val1,val2)=0) then
  537. result := false;
  538. i := 10000.0;
  539. j := 999.0;
  540. val1 := doubletofloat64(i);
  541. val2 := doubletofloat64(j);
  542. if (float64_le(val2,val1)=0) then
  543. result := false;
  544. i := -10000.0;
  545. j := -999.0;
  546. val1 := doubletofloat64(i);
  547. val2 := doubletofloat64(j);
  548. if (float64_le(val2,val1)<>0) then
  549. result := false;
  550. if not result then
  551. Fail
  552. else
  553. WriteLn('Success.');
  554. end;
  555. procedure float64testlt;
  556. var
  557. i : double;
  558. j : double;
  559. val1,val2 : float64;
  560. result : boolean;
  561. begin
  562. result := true;
  563. Write('Double < Double test...');
  564. i := 1000.0;
  565. j := 1000.0;
  566. val1 := doubletofloat64(i);
  567. val2 := doubletofloat64(j);
  568. if (float64_lt(val1,val2)<>0) then
  569. result := false;
  570. i := 999.0;
  571. j := 1000.0;
  572. val1 := doubletofloat64(i);
  573. val2 := doubletofloat64(j);
  574. if (float64_lt(val1,val2)=0) then
  575. result := false;
  576. i := -10000.0;
  577. j := -999.0;
  578. val1 := doubletofloat64(i);
  579. val2 := doubletofloat64(j);
  580. if (float64_lt(val2,val1)<>0) then
  581. result := false;
  582. if not result then
  583. Fail
  584. else
  585. WriteLn('Success.');
  586. end;
  587. procedure Float64TestInt;
  588. var
  589. _result : longint;
  590. result : boolean;
  591. begin
  592. result := true;
  593. Write('double to Longint test...');
  594. _result:=float64_to_int32(doubletofloat64(-12.12345));
  595. if _result <> -12 then
  596. result := false;
  597. _result:=float64_to_int32(doubletofloat64(12.52345));
  598. if _result <> 13 then
  599. result := false;
  600. _result:=float64_to_int32(doubletofloat64(-0.01));
  601. if _result <> 0 then
  602. result := false;
  603. if not result then
  604. Fail
  605. else
  606. WriteLn('Success.');
  607. end;
  608. {Procedure int32_to_float64( a: int32; var c: float64 ); }
  609. procedure IntTestFloat64;
  610. var
  611. result : boolean;
  612. val1 : float64;
  613. begin
  614. result := true;
  615. Write('Longint to double test...');
  616. int32_to_float64($8000,val1);
  617. if float64todouble(val1) <> $8000 then
  618. result := false;
  619. int32_to_float64(-1,val1);
  620. if float64todouble(val1) <> -1 then
  621. result := false;
  622. int32_to_float64(0,val1);
  623. if (float64todouble(val1)) <> 0.0 then
  624. result := false;
  625. int32_to_float64(-217000000,val1);
  626. if float64todouble(val1) <> -217000000 then
  627. result := false;
  628. if not result then
  629. Fail
  630. else
  631. WriteLn('Success.');
  632. end;
  633. { test procedure int64_to_float32 }
  634. procedure Int64TestFloat32;
  635. var
  636. result : boolean;
  637. val1 : float32;
  638. a : int64;
  639. sgl : single;
  640. begin
  641. result := true;
  642. Write('int64 to single test...');
  643. { cases to test : a = 0; a < 0; a > 0 }
  644. a:=0;
  645. { reset floating point exceptions flag }
  646. float_exception_flags := 0;
  647. sgl:=float32tosingle(int64_to_float32(a));
  648. if trunc(sgl) <> 0 then
  649. result := false;
  650. a:=-32768;
  651. float_exception_flags := 0;
  652. sgl:=float32tosingle(int64_to_float32(a));
  653. if trunc(sgl) <> -32768 then
  654. result := false;
  655. a:=-1000001;
  656. float_exception_flags := 0;
  657. sgl:=float32tosingle(int64_to_float32(a));
  658. if trunc(sgl) <> -1000001 then
  659. result := false;
  660. a:=12567;
  661. float_exception_flags := 0;
  662. sgl:=float32tosingle(int64_to_float32(a));
  663. if trunc(sgl) <> 12567 then
  664. result := false;
  665. a:=high(longint);
  666. float_exception_flags := 0;
  667. sgl:=float32tosingle(int64_to_float32(a));
  668. { the result might be inexact, so can't really test }
  669. if (trunc(sgl) <> high(longint)) and
  670. ((float_exception_flags and float_flag_inexact)=0) then
  671. result := false;
  672. a:=low(longint);
  673. float_exception_flags := 0;
  674. sgl:=float32tosingle(int64_to_float32(a));
  675. if (trunc(sgl) <> low(longint)) and
  676. ((float_exception_flags and float_flag_inexact)=0) then
  677. result := false;
  678. {$ifndef ver1_0}
  679. { version 1.0 returns a longint for trunc }
  680. { so these routines will automatically fail }
  681. a:=1 shl 33;
  682. float_exception_flags := 0;
  683. sgl:=float32tosingle(int64_to_float32(a));
  684. if (int64(trunc(sgl)) <> int64(1) shl 33) and
  685. ((float_exception_flags and float_flag_inexact)=0) then
  686. result := false;
  687. a:=1 shl 33;
  688. a:=-a;
  689. float_exception_flags := 0;
  690. sgl:=float32tosingle(int64_to_float32(a));
  691. if (int64(trunc(sgl)) <> -(int64(1) shl 33)) and
  692. ((float_exception_flags and float_flag_inexact)=0) then
  693. result := false;
  694. {$endif}
  695. if not result then
  696. Fail
  697. else
  698. WriteLn('Success.');
  699. end;
  700. { test procedure int64_to_float32 }
  701. procedure Int64TestFloat64;
  702. var
  703. result : boolean;
  704. val1 : float32;
  705. a : int64;
  706. float : double;
  707. begin
  708. result := true;
  709. Write('int64 to double test...');
  710. { cases to test : a = 0; a < 0; a > 0 }
  711. a:=0;
  712. { reset floating point exceptions flag }
  713. float_exception_flags := 0;
  714. float:=float64todouble(int64_to_float64(a));
  715. if trunc(float) <> 0 then
  716. result := false;
  717. a:=-32768;
  718. float_exception_flags := 0;
  719. float:=float64todouble(int64_to_float64(a));
  720. if trunc(float) <> -32768 then
  721. result := false;
  722. a:=-1000001;
  723. float_exception_flags := 0;
  724. float:=float64todouble(int64_to_float64(a));
  725. if trunc(float) <> -1000001 then
  726. result := false;
  727. a:=12567;
  728. float_exception_flags := 0;
  729. float:=float64todouble(int64_to_float64(a));
  730. if trunc(float) <> 12567 then
  731. result := false;
  732. a:=high(longint);
  733. float_exception_flags := 0;
  734. float:=float64todouble(int64_to_float64(a));
  735. { the result might be inexact, so can't really test }
  736. if (trunc(float) <> high(longint)) and
  737. ((float_exception_flags and float_flag_inexact)=0) then
  738. result := false;
  739. a:=low(longint);
  740. float_exception_flags := 0;
  741. float:=float64todouble(int64_to_float64(a));
  742. if (trunc(float) <> low(longint)) and
  743. ((float_exception_flags and float_flag_inexact)=0) then
  744. result := false;
  745. {$ifndef ver1_0}
  746. { version 1.0 returns a longint for trunc }
  747. { so these routines will automatically fail }
  748. a:=1 shl 33;
  749. float_exception_flags := 0;
  750. float:=float64todouble(int64_to_float64(a));
  751. if (int64(trunc(float)) <> int64(1) shl 33) and
  752. ((float_exception_flags and float_flag_inexact)=0) then
  753. result := false;
  754. a:=1 shl 33;
  755. a:=-a;
  756. float_exception_flags := 0;
  757. float:=float64todouble(int64_to_float64(a));
  758. if (int64(trunc(float)) <> -(int64(1) shl 33)) and
  759. ((float_exception_flags and float_flag_inexact)=0) then
  760. result := false;
  761. {$endif}
  762. if not result then
  763. Fail
  764. else
  765. WriteLn('Success.');
  766. end;
  767. Begin
  768. Float32TestEqual;
  769. Float32TestLE;
  770. Float32TestLT;
  771. Float32TestSub;
  772. Float32TestAdd;
  773. Float32TestDiv;
  774. Float32TestMul;
  775. Float32TestInt;
  776. IntTestFloat32;
  777. float64TestEqual;
  778. float64TestLE;
  779. float64TestLT;
  780. float64TestSub;
  781. float64TestAdd;
  782. float64TestDiv;
  783. float64TestMul;
  784. float64TestInt;
  785. IntTestfloat64;
  786. { int64 conversion routines }
  787. { int64testfloat32;}
  788. int64testfloat64;
  789. end.