arith04.c 22 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825
  1. /* arith04.c Copyright (C) 1991 Codemist Ltd */
  2. /*
  3. * Arithmetic functions.
  4. * <, rationalize
  5. *
  6. * Version 1.3 March 1991.
  7. */
  8. /* Signature: 3c1bf008 07-Mar-2000 */
  9. #include <stdarg.h>
  10. #include <string.h>
  11. #include <ctype.h>
  12. #include <math.h>
  13. #include "machine.h"
  14. #include "tags.h"
  15. #include "cslerror.h"
  16. #include "externs.h"
  17. #include "arith.h"
  18. #ifdef TIMEOUT
  19. #include "timeout.h"
  20. #endif
  21. #ifndef COMMON
  22. /*
  23. * In CSL mode I fudge make_ratio to be just cons, since it is ONLY
  24. * needed for (rational ...)
  25. */
  26. #define make_ratio(a, b) cons(a, b)
  27. #endif
  28. Lisp_Object make_n_word_bignum(int32 a1, unsigned32 a2, unsigned32 a3, int32 n)
  29. /*
  30. * This make a bignum with n words of data and digits a1, a2, a3 and
  31. * then n zeros. Will only be called with n>=0 and a1, a2, a3 already
  32. * correctly structured to make a valid bignum.
  33. */
  34. {
  35. int32 i;
  36. Lisp_Object w = getvector(TAG_NUMBERS, TYPE_BIGNUM, 4*(n+4)), nil;
  37. errexit();
  38. for (i=0; i<n; i++) bignum_digits(w)[i] = 0;
  39. bignum_digits(w)[n] = a3;
  40. bignum_digits(w)[n+1] = a2;
  41. bignum_digits(w)[n+2] = a1;
  42. if ((n & 1) != 0) bignum_digits(w)[n+3] = 0;
  43. return w;
  44. }
  45. static Lisp_Object make_power_of_two(int32 x)
  46. /*
  47. * Create the number 2^x where x is positive. Used to make the
  48. * denominator of a rational representation of a float. Endless fun
  49. * to cope with various small cases before I get to the general call
  50. * to make_n_word_bignum.
  51. */
  52. {
  53. if (x < 27) return fixnum_of_int(((int32)1) << x);
  54. else if (x < 30) return make_one_word_bignum(((int32)1) << x);
  55. else if (x == 30) return make_two_word_bignum(0, 0x40000000);
  56. else if (x < 61) return make_two_word_bignum(((int32)1) << (x-31), 0);
  57. else if ((x % 31) == 30)
  58. return make_n_word_bignum(0, 0x40000000, 0, (x/31)-2);
  59. else return make_n_word_bignum(((int32)1) << (x % 31), 0, 0, (x/31)-3);
  60. }
  61. static Lisp_Object make_fix_or_big2(int32 a1, unsigned32 a2)
  62. {
  63. if ((a1==0 && (a2 & fix_mask)==0) ||
  64. (a1==-1 && (a2 & 0x78000000)==0x78000000))
  65. return fixnum_of_int(a2);
  66. else if (a1==0 && (a2 & 0x40000000)==0)
  67. return make_one_word_bignum(a2);
  68. else if (a1==-1 && (a2 & 0x40000000)!=0)
  69. return make_one_word_bignum(a2|~0x7fffffff);
  70. else return make_two_word_bignum(a1, a2);
  71. }
  72. Lisp_Object rationalf(double d)
  73. {
  74. int x;
  75. CSLbool negative = NO;
  76. int32 a0, a1;
  77. unsigned32 a2;
  78. Lisp_Object nil;
  79. if (d == 0.0) return fixnum_of_int(0);
  80. if (d < 0.0) d = -d, negative = YES;
  81. d = frexp(d, &x); /* 0.5 <= abs(d) < 1.0, x = the (binary) exponent */
  82. /*
  83. * The next line is not logically needed, provided frexp() is implemented to
  84. * the relevant standard. However Zortech C release 3.0 used to get the output
  85. * range for frexp() marginally out and the following line works around the
  86. * resulting problem. I leave the code in (always) since its cost
  87. * implications are minor and other libraries may suffer the same way, and it
  88. * will be easier not to have to track the bug down from cold again!
  89. */
  90. if (d == 1.0) d = 0.5, x++;
  91. d *= TWO_31;
  92. a1 = (int32)d;
  93. if (d < 0.0) a1--;
  94. d -= (double)a1;
  95. a2 = (unsigned32)(d * TWO_31);
  96. /* Now I have the mantissa of the floating value packed into a1 and a2 */
  97. x -= 62;
  98. if (x < 0)
  99. { Lisp_Object w;
  100. /*
  101. * Here the value may have a denominator, or it may be that it will turn
  102. * out to be representable as an integer.
  103. */
  104. while ((a2 & 1) == 0 && x < 0)
  105. { a2 = (a2 >> 1) | ((a1 & 1) << 30);
  106. a1 = a1 >> 1;
  107. #ifdef SIGNED_SHIFTS_ARE_LOGICAL
  108. if (a1 & 0x40000000) a1 |= ~0x7fffffff;
  109. #endif
  110. x++;
  111. if (x == 0)
  112. { if (negative)
  113. { if (a2 == 0) a1 = -a1;
  114. else
  115. { a2 = clear_top_bit(-(int32)a2);
  116. a1 = ~a1;
  117. }
  118. }
  119. return make_fix_or_big2(a1, a2);
  120. }
  121. }
  122. if (negative)
  123. { if (a2 == 0) a1 = -a1;
  124. else
  125. { a2 = clear_top_bit(-(int32)a2);
  126. a1 = ~a1;
  127. }
  128. }
  129. w = make_fix_or_big2(a1, a2);
  130. errexit();
  131. x = -x;
  132. /*
  133. * Remember: in CSL mode make_ratio is just cons
  134. */
  135. if (x < 27) return make_ratio(w, fixnum_of_int(((int32)1) << x));
  136. else
  137. { Lisp_Object d, nil;
  138. push(w);
  139. d = make_power_of_two(x);
  140. pop(w);
  141. errexit();
  142. return make_ratio(w, d);
  143. }
  144. }
  145. else
  146. {
  147. /*
  148. * here the floating point value is quite large, and I need to create
  149. * a multi-word bignum for it.
  150. */
  151. int x1;
  152. if (negative)
  153. { if (a2 == 0) a1 = -a1;
  154. else
  155. { a2 = clear_top_bit(-(int32)a2);
  156. a1 = ~a1;
  157. }
  158. }
  159. if (a1 < 0)
  160. { a0 = -1;
  161. a1 = clear_top_bit(a1);
  162. }
  163. else a0 = 0;
  164. x1 = x / 31;
  165. x = x % 31;
  166. a0 = (a0 << x) | (a1 >> (31-x));
  167. a1 = clear_top_bit(a1 << x) | (a2 >> (31-x));
  168. a2 = clear_top_bit(a2 << x);
  169. return make_n_word_bignum(a0, a1, a2, x1);
  170. }
  171. }
  172. #ifdef COMMON
  173. static Lisp_Object rationalizef(double d)
  174. /*
  175. * This is expected to give a 'nice' rational approximation to the
  176. * floating point value d.
  177. */
  178. {
  179. double dd;
  180. Lisp_Object p, q, nil;
  181. if (d == 0.0) return fixnum_of_int(0);
  182. else if (d < 0.0) dd = -d; else dd = d;
  183. p = rationalf(dd);
  184. errexit();
  185. q = denominator(p);
  186. p = numerator(p);
  187. /* /* No cleaning up done, yet. Need to start to produce continued
  188. * fraction for p/q and truncate it at some suitable point to get
  189. * a sensible approximation. Since this is only needed in Common Lisp
  190. * mode, and seems a bit specialist even then I am not going to rush into
  191. * cobbling up the code (which I have done before and is basically OK,
  192. * save that the stopping criteria are pretty delicate).
  193. */
  194. if (d < 0.0)
  195. { p = negate(p);
  196. errexit();
  197. }
  198. return make_ratio(p, q);
  199. }
  200. #endif
  201. Lisp_Object rational(Lisp_Object a)
  202. {
  203. switch ((int)a & TAG_BITS)
  204. {
  205. case TAG_FIXNUM:
  206. return a;
  207. #ifdef COMMON
  208. case TAG_SFLOAT:
  209. { Float_union aa;
  210. aa.i = a - TAG_SFLOAT;
  211. return rationalf((double)aa.f);
  212. }
  213. #endif
  214. case TAG_NUMBERS:
  215. { int32 ha = type_of_header(numhdr(a));
  216. switch (ha)
  217. {
  218. case TYPE_BIGNUM:
  219. #ifdef COMMON
  220. case TYPE_RATNUM:
  221. #endif
  222. return a;
  223. default:
  224. return aerror1("bad arg for rational", a);
  225. }
  226. }
  227. case TAG_BOXFLOAT:
  228. return rationalf(float_of_number(a));
  229. default:
  230. return aerror1("bad arg for rational", a);
  231. }
  232. }
  233. #ifdef COMMON
  234. Lisp_Object rationalize(Lisp_Object a)
  235. {
  236. switch (a & TAG_BITS)
  237. {
  238. case TAG_FIXNUM:
  239. return a;
  240. #ifdef COMMON
  241. case TAG_SFLOAT:
  242. { Float_union aa;
  243. aa.i = a - TAG_SFLOAT;
  244. return rationalizef((double)aa.f);
  245. }
  246. #endif
  247. case TAG_NUMBERS:
  248. { int32 ha = type_of_header(numhdr(a));
  249. switch (ha)
  250. {
  251. case TYPE_BIGNUM:
  252. #ifdef COMMON
  253. case TYPE_RATNUM:
  254. #endif
  255. return a;
  256. default:
  257. return aerror1("bad arg for rationalize", a);
  258. }
  259. }
  260. case TAG_BOXFLOAT:
  261. return rationalizef(float_of_number(a));
  262. default:
  263. return aerror1("bad arg for rationalize", a);
  264. }
  265. }
  266. #endif
  267. /*
  268. * Arithmetic comparison: lessp
  269. */
  270. #ifdef COMMON
  271. static CSLbool lesspis(Lisp_Object a, Lisp_Object b)
  272. {
  273. Float_union bb;
  274. bb.i = b - TAG_SFLOAT;
  275. /*
  276. * Any fixnum can be converted to a float without introducing any
  277. * error at all...
  278. */
  279. return (double)int_of_fixnum(a) < (double)bb.f;
  280. }
  281. #endif
  282. CSLbool lesspib(Lisp_Object a, Lisp_Object b)
  283. /*
  284. * a fixnum and a bignum can never be equal, and the magnitude of
  285. * the bignum must be at least as great as that of the fixnum, hence
  286. * to do a comparison I just need to look at sign of the bignum.
  287. */
  288. {
  289. int32 len = bignum_length(b);
  290. int32 msd = bignum_digits(b)[(len>>2)-2];
  291. CSL_IGNORE(a);
  292. return (msd >= 0);
  293. }
  294. #ifdef COMMON
  295. static CSLbool lesspir(Lisp_Object a, Lisp_Object b)
  296. {
  297. /*
  298. * compute a < p/q as a*q < p
  299. */
  300. push(numerator(b));
  301. a = times2(a, denominator(b));
  302. pop(b);
  303. return lessp2(a, b);
  304. }
  305. #endif
  306. #define lesspif(a, b) ((double)int_of_fixnum(a) < float_of_number(b))
  307. CSLbool lesspdb(double a, Lisp_Object b)
  308. /*
  309. * a is a floating point number and b a bignum. Compare them.
  310. */
  311. {
  312. int32 n = (bignum_length(b) >> 2) - 2;
  313. int32 bn = (int32)bignum_digits(b)[n];
  314. /*
  315. * The value represented by b can not be in the range that fixnums
  316. * cover, so if a is in that range I need only inspect the sign of b.
  317. */
  318. if ((double)(-0x08000000) <= a &&
  319. a <= (double)(0x7fffffff))
  320. return (bn >= 0);
  321. /*
  322. * If b is a one-word bignum I can convert it to floating point
  323. * with no loss of accuracy at all.
  324. */
  325. if (n == 0) return a < (double)bn;
  326. /*
  327. * For two-digit bignums I first check if the float is so big that I can
  328. * tell that it dominames the bignum, and if not I subtract the top digit
  329. * of the bignum from both sides... in the critical case where the two
  330. * values are almost the same that subtraction will not lead to loss of
  331. * accuracy (at least provided that my floating point was implemented
  332. * with a guard bit..)
  333. */
  334. if (n == 1)
  335. { if (1.0e19 < a) return NO;
  336. else if (a < -1.0e19) return YES;
  337. a -= TWO_31*(int32)bn;
  338. return a < (double)bignum_digits(b)[0];
  339. }
  340. /*
  341. * If the two operands differ in their signs then all is easy.
  342. */
  343. if (bn >= 0 && a < 0.0) return YES;
  344. if (bn < 0 && a >= 0.0) return NO;
  345. /*
  346. * Now I have a 3 or more digit bignum, so here I will (in effect)
  347. * convert the float to a bignum and then perform the comparison.. that
  348. * does the best I can to avoid error. I do not actually have to create
  349. * a datastructure for the bignum provided I can collect up the data that
  350. * would have to be stored in it. See lisp_fix (arith8.c) for related code.
  351. */
  352. { int32 a0, a1, a2;
  353. int x, x1;
  354. a = frexp(a, &x); /* 0.5 <= abs(a) < 1.0, x = (binary) exponent */
  355. if (a == 1.0) a = 0.5, x++; /* For Zortech */
  356. a *= TWO_31;
  357. a1 = (int32)a; /* 2^31 > |a| >= 2^30 */
  358. if (a < 0.0) a1--; /* now maybe a1 is -2^31 */
  359. a -= (double)a1;
  360. a2 = (unsigned32)(a * TWO_31); /* This conversion should be exact */
  361. x -= 62;
  362. /*
  363. * If the float is smaller in absolute value than the bignum life is easy
  364. */
  365. if (x < 0) return (bn >= 0);
  366. x1 = x/31 + 2;
  367. if (n != x1)
  368. { if (n < x1) return a < 0.0;
  369. else return (bn >= 0);
  370. }
  371. /*
  372. * Now the most jolly bit - the two numbers have the same sign and involve
  373. * the same number of digits.
  374. */
  375. if (a1 < 0)
  376. { a0 = -1;
  377. a1 = clear_top_bit(a1);
  378. }
  379. else a0 = 0;
  380. x = x % 31;
  381. a0 = (a0 << x) | (a1 >> (31-x));
  382. a1 = clear_top_bit(a1 << x) | (a2 >> (31-x));
  383. a2 = clear_top_bit(a2 << x);
  384. if (a0 != bn) return a0 < bn;
  385. bn = bignum_digits(b)[n-1];
  386. if (a1 != bn) return a1 < bn;
  387. return a2 < (int32)bignum_digits(b)[n-2];
  388. }
  389. }
  390. CSLbool lesspbd(Lisp_Object b, double a)
  391. /*
  392. * Code as for lesspdb, but use '>' test instead of '<'
  393. */
  394. {
  395. int32 n = (bignum_length(b) >> 2) - 2;
  396. int32 bn = (int32)bignum_digits(b)[n];
  397. /*
  398. * The value represented by b can not be in the range that fixnums
  399. * cover, so if a is in that range I need only inspect the sign of b.
  400. */
  401. if ((double)(-0x08000000) <= a &&
  402. a <= (double)(0x7fffffff))
  403. return (bn < 0);
  404. /*
  405. * If b is a one-word bignum I can convert it to floating point
  406. * with no loss of accuracy at all.
  407. */
  408. if (n == 0) return (double)bn < a;
  409. /*
  410. * For two-digit bignums I first check if the float is so big that I can
  411. * tell that it dominates the bignum, and if not I subtract the top digit
  412. * of the bignum from both sides... in the critical case where the two
  413. * values are almost the same that subtraction will not lead to loss of
  414. * accuracy (at least provided that my floating point was implemented
  415. * with a guard bit..)
  416. */
  417. if (n == 1)
  418. { if (1.0e19 < a) return YES;
  419. else if (a < -1.0e19) return NO;
  420. a -= TWO_31 * (double)bn;
  421. return (double)bignum_digits(b)[0] < a;
  422. }
  423. /*
  424. * If the two operands differ in their signs then all is easy.
  425. */
  426. if (bn >= 0 && a < 0.0) return NO;
  427. if (bn < 0 && a >= 0.0) return YES;
  428. /*
  429. * Now I have a 3 or more digit bignum, so here I will (in effect)
  430. * convert the float to a bignum and then perform the comparison.. that
  431. * does the best I can to avoid error. I do not actually have to create
  432. * a datastructure for the bignum provided I can collect up the data that
  433. * would have to be stored in it. See lisp_fix (arith8.c) for related code.
  434. */
  435. { int32 a0, a1, a2;
  436. int x, x1;
  437. a = frexp(a, &x); /* 0.5 <= abs(a) < 1.0, x = (binary) exponent */
  438. if (a == 1.0) a = 0.5, x++;
  439. a *= TWO_31;
  440. a1 = (int32)a; /* 2^31 > |a| >= 2^30 */
  441. if (a < 0.0) a1--; /* now maybe a1 is -2^31 */
  442. a -= (double)a1;
  443. a2 = (unsigned32)(a * TWO_31); /* This conversion should be exact */
  444. x -= 62;
  445. /*
  446. * If the float is smaller in absolute value than the bignum life is easy
  447. */
  448. if (x < 0) return (bn < 0);
  449. x1 = x/31 + 2;
  450. if (n != x1)
  451. { if (n < x1) return a >= 0.0;
  452. else return (bn < 0);
  453. }
  454. /*
  455. * Now the most jolly bit - the two numbers have the same sign and involve
  456. * the same number of digits.
  457. */
  458. if (a1 < 0)
  459. { a0 = -1;
  460. a1 = clear_top_bit(a1);
  461. }
  462. else a0 = 0;
  463. x = x % 31;
  464. a0 = (a0 << x) | (a1 >> (31-x));
  465. a1 = clear_top_bit(a1 << x) | (a2 >> (31-x));
  466. a2 = clear_top_bit(a2 << x);
  467. if (a0 != bn) return a0 > bn;
  468. bn = bignum_digits(b)[n-1];
  469. if (a1 != bn) return a1 > bn;
  470. return a2 > (int32)bignum_digits(b)[n-2];
  471. }
  472. }
  473. #ifdef COMMON
  474. static CSLbool lessprr(Lisp_Object a, Lisp_Object b)
  475. {
  476. Lisp_Object c;
  477. push2(a, b);
  478. c = times2(numerator(a), denominator(b));
  479. pop2(b, a);
  480. push(c);
  481. b = times2(numerator(b), denominator(a));
  482. pop(c);
  483. return lessp2(c, b);
  484. }
  485. CSLbool lesspdr(double a, Lisp_Object b)
  486. /*
  487. * Compare float with ratio... painfully expensive.
  488. */
  489. {
  490. Lisp_Object a1 = rationalf(a), nil;
  491. errexit();
  492. return lessprr(a1, b);
  493. }
  494. CSLbool lessprd(Lisp_Object a, double b)
  495. /*
  496. * Compare float with ratio.
  497. */
  498. {
  499. Lisp_Object b1 = rationalf(b), nil;
  500. errexit();
  501. return lessprr(a, b1);
  502. }
  503. static CSLbool lesspsi(Lisp_Object a, Lisp_Object b)
  504. {
  505. Float_union aa;
  506. aa.i = a - TAG_SFLOAT;
  507. return (double)aa.f < (double)int_of_fixnum(b);
  508. }
  509. static CSLbool lesspsb(Lisp_Object a, Lisp_Object b)
  510. {
  511. Float_union aa;
  512. aa.i = a - TAG_SFLOAT;
  513. return lesspdb((double)aa.f, b);
  514. }
  515. static CSLbool lesspsr(Lisp_Object a, Lisp_Object b)
  516. {
  517. Float_union aa;
  518. aa.i = a - TAG_SFLOAT;
  519. return lesspdr((double)aa.f, b);
  520. }
  521. static CSLbool lesspsf(Lisp_Object a, Lisp_Object b)
  522. {
  523. Float_union aa;
  524. aa.i = a - TAG_SFLOAT;
  525. return (double)aa.f < float_of_number(b);
  526. }
  527. #endif
  528. CSLbool lesspbi(Lisp_Object a, Lisp_Object b)
  529. {
  530. int32 len = bignum_length(a);
  531. int32 msd = bignum_digits(a)[(len>>2)-2];
  532. CSL_IGNORE(b);
  533. return (msd < 0);
  534. }
  535. #ifdef COMMON
  536. static CSLbool lesspbs(Lisp_Object a, Lisp_Object b)
  537. {
  538. Float_union bb;
  539. bb.i = b - TAG_SFLOAT;
  540. return lesspbd(a, (double)bb.f);
  541. }
  542. #endif
  543. static CSLbool lesspbb(Lisp_Object a, Lisp_Object b)
  544. {
  545. int32 lena = bignum_length(a),
  546. lenb = bignum_length(b);
  547. if (lena > lenb)
  548. { int32 msd = bignum_digits(a)[(lena>>2)-2];
  549. return (msd < 0);
  550. }
  551. else if (lenb > lena)
  552. { int32 msd = bignum_digits(b)[(lenb>>2)-2];
  553. return (msd >= 0);
  554. }
  555. lena = (lena>>2)-2;
  556. /* lenb == lena here */
  557. { int32 msa = bignum_digits(a)[lena],
  558. msb = bignum_digits(b)[lena];
  559. if (msa < msb) return YES;
  560. else if (msa > msb) return NO;
  561. /*
  562. * Now the leading digits of the numbers agree, so in particular the numbers
  563. * have the same sign.
  564. */
  565. while (--lena >= 0)
  566. { unsigned32 da = bignum_digits(a)[lena],
  567. db = bignum_digits(b)[lena];
  568. if (da == db) continue;
  569. return (da < db);
  570. }
  571. return NO; /* numbers are the same */
  572. }
  573. }
  574. #define lesspbr(a, b) lesspir(a, b)
  575. #define lesspbf(a, b) lesspbd(a, float_of_number(b))
  576. #ifdef COMMON
  577. static CSLbool lesspri(Lisp_Object a, Lisp_Object b)
  578. {
  579. push(numerator(a));
  580. b = times2(b, denominator(a));
  581. pop(a);
  582. return lessp2(a, b);
  583. }
  584. static CSLbool lessprs(Lisp_Object a, Lisp_Object b)
  585. {
  586. Float_union bb;
  587. bb.i = b - TAG_SFLOAT;
  588. return lessprd(a, (double)bb.f);
  589. }
  590. #define lessprb(a, b) lesspri(a, b)
  591. #define lessprf(a, b) lessprd(a, float_of_number(b))
  592. #endif
  593. #define lesspfi(a, b) (float_of_number(a) < (double)int_of_fixnum(b))
  594. #ifdef COMMON
  595. static CSLbool lesspfs(Lisp_Object a, Lisp_Object b)
  596. {
  597. Float_union bb;
  598. bb.i = b - TAG_SFLOAT;
  599. return float_of_number(a) < (double)bb.f;
  600. }
  601. #endif
  602. #define lesspfb(a, b) lesspdb(float_of_number(a), b)
  603. #define lesspfr(a, b) lesspfb(a, b)
  604. #define lesspff(a, b) (float_of_number(a) < float_of_number(b))
  605. CSLbool greaterp2(Lisp_Object a, Lisp_Object b)
  606. {
  607. return lessp2(b, a);
  608. }
  609. CSLbool lessp2(Lisp_Object a, Lisp_Object b)
  610. /*
  611. * Note that this type-dispatch does not permit complex numbers to
  612. * be compared - their presence will lead to an exception being raised.
  613. * This shortens the code (marginally).
  614. */
  615. {
  616. Lisp_Object nil = C_nil;
  617. if (exception_pending()) return NO;
  618. switch ((int)a & TAG_BITS)
  619. {
  620. case TAG_FIXNUM:
  621. switch ((int)b & TAG_BITS)
  622. {
  623. case TAG_FIXNUM:
  624. /* For fixnums the comparison happens directly */
  625. return ((int32)a < (int32)b);
  626. #ifdef COMMON
  627. case TAG_SFLOAT:
  628. return lesspis(a, b);
  629. #endif
  630. case TAG_NUMBERS:
  631. { int32 hb = type_of_header(numhdr(b));
  632. switch (hb)
  633. {
  634. case TYPE_BIGNUM:
  635. return lesspib(a, b);
  636. #ifdef COMMON
  637. case TYPE_RATNUM:
  638. return lesspir(a, b);
  639. #endif
  640. default:
  641. return (CSLbool)aerror2("bad arg for lessp", a, b);
  642. }
  643. }
  644. case TAG_BOXFLOAT:
  645. return lesspif(a, b);
  646. default:
  647. return (CSLbool)aerror2("bad arg for lessp", a, b);
  648. }
  649. #ifdef COMMON
  650. case TAG_SFLOAT:
  651. switch (b & TAG_BITS)
  652. {
  653. case TAG_FIXNUM:
  654. return lesspsi(a, b);
  655. case TAG_SFLOAT:
  656. { Float_union aa, bb;
  657. aa.i = a - TAG_SFLOAT;
  658. bb.i = b - TAG_SFLOAT;
  659. return (aa.f < bb.f);
  660. }
  661. case TAG_NUMBERS:
  662. { int32 hb = type_of_header(numhdr(b));
  663. switch (hb)
  664. {
  665. case TYPE_BIGNUM:
  666. return lesspsb(a, b);
  667. case TYPE_RATNUM:
  668. return lesspsr(a, b);
  669. default:
  670. return (CSLbool)aerror2("bad arg for lessp", a, b);
  671. }
  672. }
  673. case TAG_BOXFLOAT:
  674. return lesspsf(a, b);
  675. default:
  676. return (CSLbool)aerror2("bad arg for lessp", a, b);
  677. }
  678. #endif
  679. case TAG_NUMBERS:
  680. { int32 ha = type_of_header(numhdr(a));
  681. switch (ha)
  682. {
  683. case TYPE_BIGNUM:
  684. switch ((int)b & TAG_BITS)
  685. {
  686. case TAG_FIXNUM:
  687. return lesspbi(a, b);
  688. #ifdef COMMON
  689. case TAG_SFLOAT:
  690. return lesspbs(a, b);
  691. #endif
  692. case TAG_NUMBERS:
  693. { int32 hb = type_of_header(numhdr(b));
  694. switch (hb)
  695. {
  696. case TYPE_BIGNUM:
  697. return lesspbb(a, b);
  698. #ifdef COMMON
  699. case TYPE_RATNUM:
  700. return lesspbr(a, b);
  701. #endif
  702. default:
  703. return (CSLbool)aerror2("bad arg for lessp", a, b);
  704. }
  705. }
  706. case TAG_BOXFLOAT:
  707. return lesspbf(a, b);
  708. default:
  709. return (CSLbool)aerror2("bad arg for lessp", a, b);
  710. }
  711. #ifdef COMMON
  712. case TYPE_RATNUM:
  713. switch (b & TAG_BITS)
  714. {
  715. case TAG_FIXNUM:
  716. return lesspri(a, b);
  717. case TAG_SFLOAT:
  718. return lessprs(a, b);
  719. case TAG_NUMBERS:
  720. { int32 hb = type_of_header(numhdr(b));
  721. switch (hb)
  722. {
  723. case TYPE_BIGNUM:
  724. return lessprb(a, b);
  725. case TYPE_RATNUM:
  726. return lessprr(a, b);
  727. default:
  728. return (CSLbool)aerror2("bad arg for lessp", a, b);
  729. }
  730. }
  731. case TAG_BOXFLOAT:
  732. return lessprf(a, b);
  733. default:
  734. return (CSLbool)aerror2("bad arg for lessp", a, b);
  735. }
  736. #endif
  737. default: return (CSLbool)aerror2("bad arg for lessp", a, b);
  738. }
  739. }
  740. case TAG_BOXFLOAT:
  741. switch ((int)b & TAG_BITS)
  742. {
  743. case TAG_FIXNUM:
  744. return lesspfi(a, b);
  745. #ifdef COMMON
  746. case TAG_SFLOAT:
  747. return lesspfs(a, b);
  748. #endif
  749. case TAG_NUMBERS:
  750. { int32 hb = type_of_header(numhdr(b));
  751. switch (hb)
  752. {
  753. case TYPE_BIGNUM:
  754. return lesspfb(a, b);
  755. #ifdef COMMON
  756. case TYPE_RATNUM:
  757. return lesspfr(a, b);
  758. #endif
  759. default:
  760. return (CSLbool)aerror2("bad arg for lessp", a, b);
  761. }
  762. }
  763. case TAG_BOXFLOAT:
  764. return lesspff(a, b);
  765. default:
  766. return (CSLbool)aerror2("bad arg for lessp", a, b);
  767. }
  768. default:
  769. return (CSLbool)aerror2("bad arg for lessp", a, b);
  770. }
  771. }
  772. /* end of arith04.c */