home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / num_co.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  25.9 KB  |  1,435 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.     num_co.c
  24.     IMPLEMENTATION-DEPENDENT
  25.  
  26.     This file contains those functions
  27.     that know the representation of floating-point numbers.
  28. */    
  29. #define IN_NUM_CO
  30.  
  31. #include "include.h"
  32. #include "num_include.h"
  33. #include "mp.h"
  34.  
  35. object plus_half, minus_half;
  36.  
  37. #ifdef CONVEX
  38. #define VAX
  39. #endif
  40.  
  41. #ifdef VAX
  42. /*
  43.     radix = 2
  44.  
  45.     SEEEEEEEEHHHHHHH    The redundant most significant fraction bit
  46.     HHHHHHHHHHHHHHHH    is not expressed.
  47.     LLLLLLLLLLLLLLLL
  48.     LLLLLLLLLLLLLLLL
  49. */
  50. #endif
  51. #ifdef IBMRT
  52.  
  53.  
  54.  
  55.  
  56.  
  57.  
  58.  
  59.  
  60. #endif
  61. #ifdef IEEEFLOAT
  62. #ifdef NS32K
  63.  
  64.  
  65.  
  66.  
  67.  
  68.  
  69.  
  70. #else
  71. /*
  72.     radix = 2
  73.  
  74.     SEEEEEEEEEEEHHHHHHHHHHHHHHHHHHHH    The redundant most
  75.     LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL    significant fraction bit
  76.                         is not expressed.
  77. */
  78. #endif
  79. #endif
  80. #ifdef MV
  81.  
  82.  
  83.  
  84.  
  85.  
  86.  
  87. #endif
  88. #ifdef S3000
  89. /*
  90.     radix = 16
  91.  
  92.     SEEEEEEEHHHHHHHHHHHHHHHHHHHHHHHH
  93.     LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL
  94. */
  95. #endif
  96. integer_decode_double(d, hp, lp, ep, sp)
  97. double d;
  98. int *hp, *lp, *ep, *sp;
  99. {
  100.     int h, l;
  101.  
  102.     if (d == 0.0) {
  103.         *hp = *lp = 0;
  104.         *ep = 0;
  105.         *sp = 1;
  106.         return;
  107.     }
  108. #ifdef NS32K
  109.  
  110.  
  111. #else
  112.     h = *((int *)(&d) + HIND);
  113.     l = *((int *)(&d) + LIND);
  114. #endif
  115. #ifdef VAX
  116.     *ep = ((h >> 7) & 0xff) - 128 - 56;
  117.     h = ((h >> 15) & 0x1fffe) | (((h & 0x7f) | 0x80) << 17);
  118.     l = ((l >> 16) & 0xffff) | (l << 16);
  119.     /* is this right!!!! I don't believe it --wfs */
  120.     h = h >> 1;
  121. #endif
  122. #ifdef IEEEFLOAT
  123.     *ep = ((h & 0x7ff00000) >> 20) - 1022 - 53;
  124.     h = (h & 0x000fffff | 0x00100000);
  125. #endif
  126. #ifdef S3000
  127.     *ep = ((h & 0x7f000000) >> 24) - 64 - 14;
  128.     h = (h & 0x00ffffff);
  129. #endif
  130.     if (32-BIG_RADIX)
  131.       /* shift for making bignum */
  132.       { h = h << (32-BIG_RADIX) ; 
  133.         h |= ((l & (-1 << (32-BIG_RADIX))) >> (32-BIG_RADIX));
  134.         l &=  ~(-1 << (32-BIG_RADIX));
  135.       }
  136.     *hp = h;
  137.     *lp = l;
  138.     *sp = (d > 0.0 ? 1 : -1);
  139. }
  140.  
  141. #ifdef VAX
  142. /*
  143.     radix = 2
  144.  
  145.     SEEEEEEEEMMMMMMM    The redundant most significant fraction bit
  146.     MMMMMMMMMMMMMMMM    is not expressed.
  147. */
  148. #endif
  149. #ifdef IBMRT
  150.  
  151.  
  152.  
  153.  
  154.  
  155.  
  156. #endif
  157. #ifdef IEEEFLOAT
  158. /*
  159.     radix = 2
  160.  
  161.     SEEEEEEEEMMMMMMMMMMMMMMMMMMMMMMM    The redundant most
  162.                         significant fraction bit
  163.                         is not expressed.
  164. */
  165. #endif
  166. #ifdef MV
  167.  
  168.  
  169.  
  170.  
  171.  
  172. #endif
  173. #ifdef S3000
  174. /*
  175.     radix = 16
  176.  
  177.     SEEEEEEEMMMMMMMMMMMMMMMMMMMMMMMM
  178. */
  179. #endif
  180. integer_decode_float(d, mp, ep, sp)
  181. double d;
  182. int *mp, *ep, *sp;
  183. {
  184.     float f;
  185.     int m;
  186.  
  187.     f = d;
  188.     if (f == 0.0) {
  189.         *mp = 0;
  190.         *ep = 0;
  191.         *sp = 1;
  192.         return;
  193.     }
  194.     m = *(int *)(&f);
  195. #ifdef VAX
  196.     *ep = ((m >> 7) & 0xff) - 128 - 24;
  197.     *mp = ((m >> 16) & 0xffff) | (((m & 0x7f) | 0x80) << 16);
  198. #endif
  199. #ifdef IBMRT
  200.  
  201.  
  202. #endif
  203. #ifdef IEEEFLOAT
  204.     *ep = ((m & 0x7f800000) >> 23) - 126 - 24;
  205.     *mp = m & 0x007fffff | 0x00800000;
  206. #endif
  207. #ifdef MV
  208.  
  209.  
  210. #endif
  211. #ifdef S3000
  212.     *ep = ((m & 0x7f000000) >> 24) - 64 - 6;
  213.     *mp = m & 0x00ffffff;
  214. #endif
  215.     *sp = (f > 0.0 ? 1 : -1);
  216. }
  217.  
  218. int
  219. double_exponent(d)
  220. double d;
  221. {
  222.     if (d == 0.0)
  223.         return(0);
  224. #ifdef VAX
  225.     return(((*(int *)(&d) >> 7) & 0xff) - 128);
  226. #endif
  227. #ifdef IBMRT
  228.  
  229. #endif
  230. #ifdef IEEEFLOAT
  231. #ifdef NS32K
  232.  
  233. #else
  234.     return((((*((int *)(&d) + HIND)) & 0x7ff00000) >> 20) - 1022);
  235. #endif
  236. #endif
  237. #ifdef MV
  238.  
  239. #endif
  240. #ifdef S3000
  241.     return(((*(int *)(&d) & 0x7f000000) >> 24) - 64);
  242. #endif
  243. }
  244.  
  245. double
  246. set_exponent(d, e)
  247. double d;
  248. int e;
  249. {
  250.     double dummy;
  251.  
  252.     if (d == 0.0)
  253.         return(0.0);
  254.     *((int *)(&d) + HIND)
  255. #ifdef VAX
  256.     = *(int *)(&d) & 0xffff807f | ((e + 128) << 7) & 0x7f80;
  257. #endif
  258. #ifdef IBMRT
  259.  
  260. #endif
  261. #ifdef IEEEFLOAT
  262. #ifdef NS32K
  263.  
  264. #else
  265.     = *((int *)(&d) + HIND) & 0x800fffff | ((e + 1022) << 20) & 0x7ff00000;
  266. #endif
  267. #endif
  268. #ifdef MV
  269.  
  270. #endif
  271. #ifdef S3000
  272.     = *(int *)(&d) & 0x80ffffff | ((e + 64) << 24) & 0x7f000000;
  273. #endif
  274.     dummy = d*d;
  275.     return(d);
  276. }
  277.  
  278.  
  279. object
  280. double_to_integer(d)
  281. double d;
  282. {
  283.     int h, l, e, s;
  284.     object x, y;
  285.     object shift_integer();
  286.     vs_mark;
  287.  
  288.     if (d == 0.0)
  289.         return(small_fixnum(0));
  290.     integer_decode_double(d, &h, &l, &e, &s);
  291. #ifdef VAX
  292.     if (e <= -BIG_RADIX) {
  293.         h >>= (-e) - BIG_RADIX;
  294. #endif
  295. #ifdef IBMRT
  296.  
  297.  
  298. #endif
  299. #ifdef IEEEFLOAT
  300.     if (e <= -BIG_RADIX) {
  301.         e = (-e) - BIG_RADIX;
  302.         if (e >= BIG_RADIX)
  303.             return(small_fixnum(0));
  304.         h >>= e;
  305. #endif
  306. #ifdef MV
  307.  
  308.  
  309. #endif
  310. #ifdef S3000
  311.     if (e <= -8) {
  312.         h >>= 4*(-e) - BIG_RADIX;
  313. #endif
  314.         return(make_fixnum(s*h));
  315.     }
  316.     if (h != 0)
  317.         x = bignum2(h, l);
  318.     else
  319.         x = make_fixnum(l);
  320.     vs_push(x);
  321. #ifdef VAX
  322.     x = shift_integer(x, e);
  323. #endif
  324. #ifdef IBMRT
  325.  
  326. #endif
  327. #ifdef IEEEFLOAT
  328.     x = shift_integer(x, e);
  329. #endif
  330. #ifdef MV
  331.  
  332. #endif
  333. #ifdef S3000
  334.     x = shift_integer(x, 4*e);
  335. #endif
  336.     if (s < 0) {
  337.         vs_push(x);
  338.         x = number_negate(x);
  339.     }
  340.     vs_reset;
  341.     return(x);
  342. }
  343.  
  344. object
  345. remainder(x, y, q)
  346. object x, y, q;
  347. {
  348.     object z;
  349.  
  350.     z = number_times(q, y);
  351.     vs_push(z);
  352.     z = number_minus(x, z);
  353.     vs_pop;
  354.     return(z);
  355. }
  356.  
  357. /* Coerce X to single-float if one arg,
  358.    otherwise coerce to same float type as second arg */
  359.  
  360. Lfloat()
  361. {
  362.     double    d;
  363.     int narg;
  364.     object    x;
  365.     enum type t;
  366.  
  367.     narg = vs_top - vs_base;
  368.     if (narg < 1)
  369.         too_few_arguments();
  370.     else if (narg > 2)
  371.         too_many_arguments();
  372.     if (narg == 2) {
  373.         check_type_float(&vs_base[1]);
  374.         t = type_of(vs_base[1]);
  375.     }
  376.     x = vs_base[0];
  377.     switch (type_of(x)) {
  378.     case t_fixnum:
  379.         if (narg > 1 && t == t_shortfloat)
  380.           x = make_shortfloat((shortfloat)(fix(x)));
  381.         else
  382.           x = make_longfloat((double)(fix(x)));
  383.         break;
  384.  
  385.     case t_bignum:
  386.     case t_ratio:
  387.         d = number_to_double(x);
  388.         if (narg > 1 && t == t_shortfloat)
  389.           x = make_shortfloat((shortfloat)d);
  390.         else
  391.           x = make_longfloat(d);        
  392.         break;
  393.  
  394.     case t_shortfloat:
  395.         if (narg > 1 && t == t_shortfloat);
  396.           else
  397.             x = make_longfloat((double)(sf(x)));
  398.         break;
  399.  
  400.     case t_longfloat:
  401.         if (narg > 1 && t == t_shortfloat)
  402.             x = make_shortfloat((shortfloat)(lf(x)));
  403.         break;
  404.  
  405.     default:
  406.         FEwrong_type_argument(TSor_rational_float, x);
  407.     }
  408.     vs_base = vs_top;
  409.     vs_push(x);
  410. }
  411.  
  412. Lnumerator()
  413. {
  414.     check_arg(1);
  415.     check_type_rational(&vs_base[0]);
  416.     if (type_of(vs_base[0]) == t_ratio)
  417.         vs_base[0] = vs_base[0]->rat.rat_num;
  418. }
  419.  
  420. Ldenominator()
  421. {
  422.     check_arg(1);
  423.     check_type_rational(&vs_base[0]);
  424.     if (type_of(vs_base[0]) == t_ratio)
  425.         vs_base[0] = vs_base[0]->rat.rat_den;
  426.     else
  427.         vs_base[0] = small_fixnum(1);
  428. }
  429.  
  430. Lfloor()
  431. {
  432.     object x, y, q, q1;
  433.     double d;
  434.     int n;
  435.     object one_minus();
  436.  
  437.     n = vs_top - vs_base;
  438.     if (n == 0)
  439.         too_few_arguments();
  440.     if (n > 1)
  441.         goto TWO_ARG;
  442.     x = vs_base[0];
  443.     switch (type_of(x)) {
  444.  
  445.     case t_fixnum:
  446.     case t_bignum:
  447.         vs_push(small_fixnum(0));
  448.         return;
  449.  
  450.     case t_ratio:
  451.         q = x;
  452.         y = small_fixnum(1);
  453.         goto RATIO;
  454.  
  455.     case t_shortfloat:
  456.         d = (double)(sf(x));
  457.         q1 = double_to_integer(d);
  458.         d -= number_to_double(q1);
  459.         if (sf(x) < 0.0 && d != 0.0) {
  460.             vs_push(q1);
  461.             q1 = one_minus(q1);
  462.             d += 1.0;
  463.         }
  464.         vs_base = vs_top;
  465.         vs_push(q1);
  466.         vs_push(make_shortfloat((shortfloat)d));
  467.         return;
  468.  
  469.     case t_longfloat:
  470.         d = lf(x);
  471.         q1 = double_to_integer(d);
  472.         d -= number_to_double(q1);
  473.         if (lf(x) < 0.0 && d != 0.0) {
  474.             vs_push(q1);
  475.             q1 = one_minus(q1);
  476.             d += 1.0;
  477.         }
  478.         vs_base = vs_top;
  479.         vs_push(q1);
  480.         vs_push(make_longfloat(d));
  481.         return;
  482.  
  483.     default:
  484.         FEwrong_type_argument(TSor_rational_float, x);
  485.     }
  486.  
  487. TWO_ARG:
  488.     if (n > 2)
  489.         too_many_arguments();
  490.     x = vs_base[0];
  491.     y = vs_base[1];
  492.     if ((type_of(x) == t_fixnum || type_of(x) == t_bignum) &&
  493.         (type_of(y) == t_fixnum || type_of(y) == t_bignum)) {
  494.         vs_base = vs_top;
  495.         if (number_zerop(x)) {
  496.             vs_push(small_fixnum(0));
  497.             vs_push(small_fixnum(0));
  498.             return;
  499.         }
  500.         vs_push(Cnil);
  501.         vs_push(Cnil);
  502.         integer_quotient_remainder_1(x, y, &vs_base[0], &vs_base[1]);
  503.         if (number_minusp(x) ? number_plusp(y) : number_minusp(y)) {
  504.             if (number_zerop(vs_base[1]))
  505.                 return;
  506.             vs_base[0] = one_minus(vs_base[0]);
  507.             vs_base[1] = number_plus(vs_base[1], y);
  508.         }
  509.         return;
  510.     }
  511.     check_type_or_rational_float(&vs_base[0]);
  512.     check_type_or_rational_float(&vs_base[1]);
  513.     q = number_divide(x, y);
  514.     vs_push(q);
  515.     switch (type_of(q)) {
  516.     case t_fixnum:
  517.     case t_bignum:
  518.         vs_base = vs_top;
  519.         vs_push(q);
  520.         vs_push(small_fixnum(0));
  521.         break;
  522.     
  523.     case t_ratio:
  524.     RATIO:
  525.         q1 = integer_divide1(q->rat.rat_num, q->rat.rat_den);
  526.         if (number_minusp(q)) {
  527.             vs_push(q1);
  528.             q1 = one_minus(q1);
  529.         } else
  530.             q1 = q1;
  531.         vs_base = vs_top;
  532.         vs_push(q1);
  533.         vs_push(remainder(x, y, q1));
  534.         return;
  535.  
  536.     case t_shortfloat:
  537.     case t_longfloat:
  538.         q1 = double_to_integer(number_to_double(q));
  539.         if (number_minusp(q) && number_compare(q, q1)) {
  540.             vs_push(q1);
  541.             q1 = one_minus(q1);
  542.         } else
  543.             q1 = q1;
  544.         vs_base = vs_top;
  545.         vs_push(q1);
  546.         vs_push(remainder(x, y, q1));
  547.         return;
  548.     }
  549. }
  550.  
  551. Lceiling()
  552. {
  553.     object x, y, q, q1;
  554.     double d;
  555.     int n;
  556.     object one_plus();
  557.  
  558.     n = vs_top - vs_base;
  559.     if (n == 0)
  560.         too_few_arguments();
  561.     if (n > 1)
  562.         goto TWO_ARG;
  563.     x = vs_base[0];
  564.     switch (type_of(x)) {
  565.  
  566.     case t_fixnum:
  567.     case t_bignum:
  568.         vs_push(small_fixnum(0));
  569.         return;
  570.  
  571.     case t_ratio:
  572.         q = x;
  573.         y = small_fixnum(1);
  574.         goto RATIO;        
  575.  
  576.     case t_shortfloat:
  577.         d = (double)(sf(x));
  578.         q1 = double_to_integer(d);
  579.         d -= number_to_double(q1);
  580.         if (sf(x) > 0.0 && d != 0.0) {
  581.             vs_push(q1);
  582.             q1 = one_plus(q1);
  583.             d -= 1.0;
  584.         }
  585.         vs_base = vs_top;
  586.         vs_push(q1);
  587.         vs_push(make_shortfloat((shortfloat)d));
  588.         return;
  589.  
  590.     case t_longfloat:
  591.         d = lf(x);
  592.         q1 = double_to_integer(d);
  593.         d -= number_to_double(q1);
  594.         if (lf(x) > 0.0 && d != 0.0) {
  595.             vs_push(q1);
  596.             q1 = one_plus(q1);
  597.             d -= 1.0;
  598.         }
  599.         vs_base = vs_top;
  600.         vs_push(q1);
  601.         vs_push(make_longfloat(d));
  602.         return;
  603.  
  604.     default:
  605.         FEwrong_type_argument(TSor_rational_float, x);
  606.     }
  607.  
  608. TWO_ARG:
  609.     if (n > 2)
  610.         too_many_arguments();
  611.     x = vs_base[0];
  612.     y = vs_base[1];
  613.     if ((type_of(x) == t_fixnum || type_of(x) == t_bignum) &&
  614.         (type_of(y) == t_fixnum || type_of(y) == t_bignum)) {
  615.         vs_base = vs_top;
  616.         if (number_zerop(x)) {
  617.             vs_push(small_fixnum(0));
  618.             vs_push(small_fixnum(0));
  619.             return;
  620.         }
  621.         vs_push(Cnil);
  622.         vs_push(Cnil);
  623.         integer_quotient_remainder_1(x, y, &vs_base[0], &vs_base[1]);
  624.         if (number_plusp(x) ? number_plusp(y) : number_minusp(y)) {
  625.             if (number_zerop(vs_base[1]))
  626.                 return;
  627.             vs_base[0] = one_plus(vs_base[0]);
  628.             vs_base[1] = number_minus(vs_base[1], y);
  629.         }
  630.         return;
  631.     }
  632.     check_type_or_rational_float(&vs_base[0]);
  633.     check_type_or_rational_float(&vs_base[1]);
  634.     q = number_divide(x, y);
  635.     vs_push(q);
  636.     switch (type_of(q)) {
  637.     case t_fixnum:
  638.     case t_bignum:
  639.         vs_base = vs_top;
  640.         vs_push(q);
  641.         vs_push(small_fixnum(0));
  642.         break;
  643.     
  644.     case t_ratio:
  645.     RATIO:
  646.         q1 = integer_divide1(q->rat.rat_num, q->rat.rat_den);
  647.         if (number_plusp(q)) {
  648.             vs_push(q1);
  649.             q1 = one_plus(q1);
  650.         } else
  651.             q1 = q1;
  652.         vs_base = vs_top;
  653.         vs_push(q1);
  654.         vs_push(remainder(x, y, q1));
  655.         return;
  656.  
  657.     case t_shortfloat:
  658.     case t_longfloat:
  659.         q1 = double_to_integer(number_to_double(q));
  660.         if (number_plusp(q) && number_compare(q, q1)) {
  661.             vs_push(q1);
  662.             q1 = one_plus(q1);
  663.         } else
  664.             q1 = q1;
  665.         vs_base = vs_top;
  666.         vs_push(q1);
  667.         vs_push(remainder(x, y, q1));
  668.         return;
  669.     }
  670. }
  671.  
  672. Ltruncate()
  673. {
  674.     object x, y, q, q1;
  675.     int n;
  676.  
  677.     n = vs_top - vs_base;
  678.     if (n == 0)
  679.         too_few_arguments();
  680.     if (n > 1)
  681.         goto TWO_ARG;
  682.     x = vs_base[0];
  683.     switch (type_of(x)) {
  684.  
  685.     case t_fixnum:
  686.     case t_bignum:
  687.         vs_push(small_fixnum(0));
  688.         return;
  689.  
  690.     case t_ratio:
  691.         q1 = integer_divide1(x->rat.rat_num, x->rat.rat_den);
  692.         vs_base = vs_top;
  693.         vs_push(q1);
  694.         vs_push(number_minus(x, q1));
  695.         return;
  696.  
  697.     case t_shortfloat:
  698.         q1 = double_to_integer((double)(sf(x)));
  699.         vs_base = vs_top;
  700.         vs_push(q1);
  701.         vs_push(number_minus(x, q1));
  702.         return;
  703.  
  704.     case t_longfloat:
  705.         q1 = double_to_integer(lf(x));
  706.         vs_base = vs_top;
  707.         vs_push(q1);
  708.         vs_push(number_minus(x, q1));
  709.         return;
  710.  
  711.     default:
  712.         FEwrong_type_argument(TSor_rational_float, x);
  713.     }
  714.  
  715. TWO_ARG:
  716.     if (n > 2)
  717.         too_many_arguments();
  718.     x = vs_base[0];
  719.     y = vs_base[1];
  720.     if ((type_of(x) == t_fixnum || type_of(x) == t_bignum) &&
  721.         (type_of(y) == t_fixnum || type_of(y) == t_bignum)) {
  722.         integer_quotient_remainder_1(x, y, &vs_base[0], &vs_base[1]);
  723.         return;
  724.     }
  725.     check_type_or_rational_float(&vs_base[0]);
  726.     check_type_or_rational_float(&vs_base[1]);
  727.     q = number_divide(x, y);
  728.     vs_push(q);
  729.     switch (type_of(q)) {
  730.     case t_fixnum:
  731.     case t_bignum:
  732.         vs_base = vs_top;
  733.         vs_push(q);
  734.         vs_push(small_fixnum(0));
  735.         break;
  736.     
  737.     case t_ratio:
  738.         q1 = integer_divide1(q->rat.rat_num, q->rat.rat_den);
  739.         vs_base = vs_top;
  740.         vs_push(q1);
  741.         vs_push(remainder(x, y, q1));
  742.         return;
  743.  
  744.     case t_shortfloat:
  745.     case t_longfloat:
  746.         q1 = double_to_integer(number_to_double(q));
  747.         vs_base = vs_top;
  748.         vs_push(q1);
  749.         vs_push(remainder(x, y, q1));
  750.         return;
  751.     }
  752. }
  753.  
  754. Lround()
  755. {
  756.     object x, y, q, q1, r;
  757.     double d;
  758.     int n, c;
  759.     object one_plus(), one_minus();
  760.  
  761.     n = vs_top - vs_base;
  762.     if (n == 0)
  763.         too_few_arguments();
  764.     if (n > 1)
  765.         goto TWO_ARG;
  766.     x = vs_base[0];
  767.     switch (type_of(x)) {
  768.  
  769.     case t_fixnum:
  770.     case t_bignum:
  771.         vs_push(small_fixnum(0));
  772.         return;
  773.  
  774.     case t_ratio:
  775.         q = x;
  776.         y = small_fixnum(1);
  777.         goto RATIO;
  778.  
  779.     case t_shortfloat:
  780.         d = (double)(sf(x));
  781.         if (d >= 0.0)
  782.             q = double_to_integer(d + 0.5);
  783.         else
  784.             q = double_to_integer(d - 0.5);
  785.         d -= number_to_double(q);
  786.         if (d == 0.5 && number_oddp(q)) {
  787.             vs_push(q);
  788.             q = one_plus(q);
  789.             d = -0.5;
  790.         }
  791.         if (d == -0.5 && number_oddp(q)) {
  792.             vs_push(q);
  793.             q = one_minus(q);
  794.             d = 0.5;
  795.         }
  796.         vs_base = vs_top;
  797.         vs_push(q);
  798.         vs_push(make_shortfloat((shortfloat)d));
  799.         return;
  800.  
  801.     case t_longfloat:
  802.         d = lf(x);
  803.         if (d >= 0.0)
  804.             q = double_to_integer(d + 0.5);
  805.         else
  806.             q = double_to_integer(d - 0.5);
  807.         d -= number_to_double(q);
  808.         if (d == 0.5 && number_oddp(q)) {
  809.             vs_push(q);
  810.             q = one_plus(q);
  811.             d = -0.5;
  812.         }
  813.         if (d == -0.5 && number_oddp(q)) {
  814.             vs_push(q);
  815.             q = one_minus(q);
  816.             d = 0.5;
  817.         }
  818.         vs_base = vs_top;
  819.         vs_push(q);
  820.         vs_push(make_longfloat(d));
  821.         return;
  822.  
  823.     default:
  824.         FEwrong_type_argument(TSor_rational_float, x);
  825.     }
  826.  
  827. TWO_ARG:
  828.     if (n > 2)
  829.         too_many_arguments();
  830.     x = vs_base[0];
  831.     y = vs_base[1];
  832.     check_type_or_rational_float(&vs_base[0]);
  833.     check_type_or_rational_float(&vs_base[1]);
  834.     q = number_divide(x, y);
  835.     vs_push(q);
  836.     switch (type_of(q)) {
  837.     case t_fixnum:
  838.     case t_bignum:
  839.         vs_base = vs_top;
  840.         vs_push(q);
  841.         vs_push(small_fixnum(0));
  842.         break;
  843.     
  844.     case t_ratio:
  845.     RATIO:
  846.         q1 = integer_divide1(q->rat.rat_num, q->rat.rat_den);
  847.         vs_push(q1);
  848.         r = number_minus(q, q1);
  849.         vs_push(r);
  850.         if ((c = number_compare(r, plus_half)) > 0 ||
  851.             (c == 0 && number_oddp(q1)))
  852.             q1 = one_plus(q1);
  853.         if ((c = number_compare(r, minus_half)) < 0 ||
  854.             (c == 0 && number_oddp(q1)))
  855.             q1 = one_minus(q1);
  856.         vs_base = vs_top;
  857.         vs_push(q1);
  858.         vs_push(remainder(x, y, q1));
  859.         return;
  860.  
  861.     case t_shortfloat:
  862.     case t_longfloat:
  863.         d = number_to_double(q);
  864.         if (d >= 0.0)
  865.             q1 = double_to_integer(d + 0.5);
  866.         else
  867.             q1 = double_to_integer(d - 0.5);
  868.         d -= number_to_double(q1);
  869.         if (d == 0.5 && number_oddp(q1)) {
  870.             vs_push(q1);
  871.             q1 = one_plus(q1);
  872.         }
  873.         if (d == -0.5 && number_oddp(q1)) {
  874.             vs_push(q1);
  875.             q1 = one_minus(q1);
  876.         }
  877.         vs_base = vs_top;
  878.         vs_push(q1);
  879.         vs_push(remainder(x, y, q1));
  880.         return;
  881.     }
  882. }
  883.  
  884. Lmod()
  885. {
  886.     check_arg(2);
  887.     Lfloor();
  888.     vs_base++;
  889. }
  890.  
  891. Lrem()
  892. {
  893.     check_arg(2);
  894.     Ltruncate();
  895.     vs_base++;
  896. }
  897.  
  898.  
  899. Ldecode_float()
  900. {
  901.     object x;
  902.     double d;
  903.     int e, s;
  904.  
  905.     check_arg(1);
  906.     check_type_float(&vs_base[0]);
  907.     x = vs_base[0];
  908.     if (type_of(x) == t_shortfloat)
  909.         d = sf(x);
  910.     else
  911.         d = lf(x);
  912.     if (d >= 0.0)
  913.         s = 1;
  914.     else {
  915.         d = -d;
  916.         s = -1;
  917.     }
  918.     e = double_exponent(d);
  919.     d = set_exponent(d, 0);
  920.     vs_top = vs_base;
  921.     if (type_of(x) == t_shortfloat) {
  922.         vs_push(make_shortfloat((shortfloat)d));
  923.         vs_push(make_fixnum(e));
  924.         vs_push(make_shortfloat((shortfloat)s));
  925.     } else {
  926.         vs_push(make_longfloat(d));
  927.         vs_push(make_fixnum(e));
  928.         vs_push(make_longfloat((double)s));
  929.     }
  930. }
  931.  
  932. Lscale_float()
  933. {
  934.     object x;
  935.     double d;
  936.     int e, k;
  937.  
  938.     check_arg(2);
  939.     check_type_float(&vs_base[0]);
  940.     x = vs_base[0];
  941.     if (type_of(vs_base[1]) == t_fixnum)
  942.         k = fix(vs_base[1]);
  943.     else
  944.         FEerror("~S is an illegal exponent.", 1, vs_base[1]);
  945.     if (type_of(x) == t_shortfloat)
  946.         d = sf(x);
  947.     else
  948.         d = lf(x);
  949.     e = double_exponent(d) + k;
  950. #ifdef VAX
  951.     if (e <= -128 || e >= 128)
  952. #endif
  953. #ifdef IBMRT
  954.  
  955. #endif
  956. #ifdef IEEEFLOAT
  957.     if (type_of(x) == t_shortfloat && (e <= -126 || e >= 130) ||
  958.         type_of(x) == t_longfloat && (e <= -1022 || e >= 1026))
  959. #endif
  960. #ifdef MV
  961.  
  962. #endif
  963. #ifdef S3000
  964.     if (e < -64 || e >= 64)
  965. #endif
  966.         FEerror("~S is an illegal exponent.", 1, vs_base[1]);
  967.     d = set_exponent(d, e);
  968.     vs_pop;
  969.     if (type_of(x) == t_shortfloat)
  970.         vs_base[0] = make_shortfloat((shortfloat)d);
  971.     else
  972.         vs_base[0] = make_longfloat(d);
  973. }
  974.  
  975. Lfloat_radix()
  976. {
  977.     check_arg(1);
  978.     check_type_float(&vs_base[0]);
  979. #ifdef VAX
  980.     vs_base[0] = small_fixnum(2);
  981. #endif
  982. #ifdef IBMRT
  983.  
  984. #endif
  985. #ifdef IEEEFLOAT
  986.     vs_base[0] = small_fixnum(2);
  987. #endif
  988. #ifdef MV
  989.  
  990. #endif
  991. #ifdef S3000
  992.     vs_base[0] = small_fixnum(16);
  993. #endif
  994. }
  995.  
  996. Lfloat_sign()
  997. {
  998.     object x;
  999.     int narg;
  1000.     double d, f;
  1001.  
  1002.     narg = vs_top - vs_base;
  1003.     if (narg < 1)
  1004.         too_few_arguments();
  1005.     else if (narg > 2)
  1006.         too_many_arguments();
  1007.     check_type_float(&vs_base[0]);
  1008.     x = vs_base[0];
  1009.     if (type_of(x) == t_shortfloat)
  1010.         d = sf(x);
  1011.     else
  1012.         d = lf(x);
  1013.     if (narg == 1)
  1014.         f = 1.0;
  1015.     else {
  1016.         check_type_float(&vs_base[1]);
  1017.         x = vs_base[1];
  1018.         if (type_of(x) == t_shortfloat)
  1019.             f = sf(x);
  1020.         else
  1021.             f = lf(x);
  1022.         if (f < 0.0)
  1023.             f = -f;
  1024.     }
  1025.     if (d < 0.0)
  1026.         f = -f;
  1027.     vs_top = vs_base;
  1028.     if (type_of(x) == t_shortfloat)
  1029.         vs_push(make_shortfloat((shortfloat)f));
  1030.     else
  1031.         vs_push(make_longfloat(f));
  1032. }
  1033.  
  1034. Lfloat_digits()
  1035. {
  1036.     check_arg(1);
  1037.     check_type_float(&vs_base[0]);
  1038.     if (type_of(vs_base[0]) == t_shortfloat)
  1039.         vs_base[0] = small_fixnum(24);
  1040.     else
  1041.         vs_base[0] = small_fixnum(53);
  1042. }
  1043.  
  1044. Lfloat_precision()
  1045. {
  1046.     object x;
  1047.  
  1048.     check_arg(1);
  1049.     check_type_float(&vs_base[0]);
  1050.     x = vs_base[0];
  1051.     if (type_of(x) == t_shortfloat)
  1052.         if (sf(x) == 0.0)
  1053.             vs_base[0] = small_fixnum(0);
  1054.         else
  1055.             vs_base[0] = small_fixnum(24);
  1056.     else
  1057.         if (lf(x) == 0.0)
  1058.             vs_base[0] = small_fixnum(0);
  1059.         else
  1060. #ifdef VAX
  1061.             vs_base[0] = small_fixnum(53);
  1062. #endif
  1063. #ifdef IBMRT
  1064.  
  1065. #endif
  1066. #ifdef IEEEFLOAT
  1067.             vs_base[0] = small_fixnum(53);
  1068. #endif
  1069. #ifdef MV
  1070.  
  1071. #endif
  1072. #ifdef S3000
  1073.             vs_base[0] = small_fixnum(53);
  1074. #endif
  1075. }
  1076.  
  1077. Linteger_decode_float()
  1078. {
  1079.     object x;
  1080.     int h, l, e, s;
  1081.  
  1082.     check_arg(1);
  1083.     check_type_float(&vs_base[0]);
  1084.     x = vs_base[0];
  1085.     vs_base = vs_top;
  1086.     if (type_of(x) == t_longfloat) {
  1087.         integer_decode_double(lf(x), &h, &l, &e, &s);
  1088.         if (h != 0)
  1089.             vs_push(bignum2(h, l));
  1090.         else
  1091.             vs_push(make_fixnum(l));
  1092.         vs_push(make_fixnum(e));
  1093.         vs_push(make_fixnum(s));
  1094.     } else {
  1095.         integer_decode_float((double)(sf(x)), &h, &e, &s);
  1096.         vs_push(make_fixnum(h));
  1097.         vs_push(make_fixnum(e));
  1098.         vs_push(make_fixnum(s));
  1099.     }
  1100. }
  1101.  
  1102. Lcomplex()
  1103. {
  1104.     object    x, r, i;
  1105.     int narg;
  1106.  
  1107.     narg = vs_top - vs_base;
  1108.     if (narg < 1)
  1109.         too_few_arguments();
  1110.     if (narg > 2)
  1111.         too_many_arguments();
  1112.     check_type_or_rational_float(&vs_base[0]);
  1113.     r = vs_base[0];
  1114.     if (narg == 1)
  1115.         i = small_fixnum(0);
  1116.     else {
  1117.         check_type_or_rational_float(&vs_base[1]);
  1118.         i = vs_base[1];
  1119.     }
  1120.     vs_top = vs_base;
  1121.     vs_push(make_complex(r, i));
  1122. }
  1123.  
  1124. Lrealpart()
  1125. {
  1126.     object    r, x;
  1127.  
  1128.     check_arg(1);
  1129.     check_type_number(&vs_base[0]);
  1130.     x = vs_base[0];
  1131.     if (type_of(x) == t_complex)
  1132.         vs_base[0] = x->cmp.cmp_real;
  1133. }
  1134.  
  1135. Limagpart()
  1136. {
  1137.     object x;
  1138.  
  1139.     check_arg(1);
  1140.     check_type_number(&vs_base[0]);
  1141.     x = vs_base[0];
  1142.     switch (type_of(x)) {
  1143.     case t_fixnum:
  1144.     case t_bignum:
  1145.     case t_ratio:
  1146.         vs_base[0] = small_fixnum(0);
  1147.         break;
  1148.     case t_shortfloat:
  1149.         vs_base[0] = shortfloat_zero;
  1150.         break;
  1151.     case t_longfloat:
  1152.         vs_base[0] = longfloat_zero;
  1153.         break;
  1154.     case t_complex:
  1155.         vs_base[0] = x->cmp.cmp_imag;
  1156.         break;
  1157.     }
  1158. }
  1159.  
  1160. static float sf1,sf2;
  1161. static sf_eql()
  1162. {return(sf1==sf2);}
  1163.  
  1164. static lf_eql(a,b)
  1165.      double a,b;
  1166. {return(a==b);}
  1167. #define LF_EQL(a,b) lf_eql((double)(a),(double)(b))
  1168. #define SF_EQL(a,b) (sf1=a,sf2=b,sf_eql())
  1169.  
  1170. init_num_co()
  1171. {
  1172.     int l[2];
  1173.     float smallest_float, biggest_float;
  1174.     double smallest_double, biggest_double;
  1175.     float float_epsilon, float_negative_epsilon;
  1176.     double double_epsilon, double_negative_epsilon;
  1177.  
  1178. #ifdef VAX
  1179.     l[0] = 0x80;
  1180.     l[1] = 0;
  1181.     smallest_float = *(float *)l;
  1182.     smallest_double = *(double *)l;
  1183. #endif
  1184.  
  1185. #ifdef IEEEFLOAT
  1186. #ifdef NS32K
  1187.  
  1188.  
  1189.  
  1190.  
  1191.  
  1192. #else
  1193.  
  1194.     ((int *) &smallest_float)[0]= 1;
  1195.     ((int *) &smallest_double)[HIND] = 0;
  1196.     ((int *) &smallest_double)[LIND] = 1;
  1197.  
  1198. #endif
  1199. #endif
  1200.  
  1201. #ifdef MV
  1202.  
  1203.  
  1204.  
  1205.  
  1206. #endif
  1207.  
  1208. #ifdef S3000
  1209.     l[0] = 0x00100000;
  1210.     l[1] = 0;
  1211.     smallest_float = *(float *)l;
  1212.     smallest_double = *(double *)l;
  1213. #endif
  1214.  
  1215. #ifdef VAX
  1216.     l[0] = 0xffff7fff;
  1217.     l[1] = 0xffffffff;
  1218.     biggest_float = *(float *)l;
  1219.     biggest_double = *(double *)l;
  1220. #endif
  1221.  
  1222. #ifdef IBMRT
  1223.  
  1224.  
  1225.  
  1226.  
  1227. #endif
  1228.  
  1229. #ifdef IEEEFLOAT
  1230. #ifdef NS32K
  1231.  
  1232.  
  1233.  
  1234.  
  1235.  
  1236. #else
  1237.  
  1238.     ((int *) &biggest_float)[0]= 0x7f7fffff;
  1239.     ((int *) &biggest_double)[HIND] = 0x7fefffff;
  1240.     ((int *) &biggest_double)[LIND] = 0xffffffff;
  1241.  
  1242. #ifdef BAD_FPCHIP
  1243.  /* &&&& I am adding junk values to get past debugging */
  1244.         biggest_float = 1.0e37;
  1245.         smallest_float = 1.0e-37;
  1246.         biggest_double = 1.0e308;
  1247.         smallest_double = 1.0e-308;
  1248.         printf("\n Used fake values for float max and mins ");
  1249. #endif
  1250. #endif
  1251. #endif
  1252.  
  1253. #ifdef MV
  1254.  
  1255.  
  1256.  
  1257.  
  1258.  
  1259.  
  1260.  
  1261.  
  1262.  
  1263.  
  1264.  
  1265.  
  1266.  
  1267.  
  1268.  
  1269.  
  1270.  
  1271.  
  1272.  
  1273.  
  1274.  
  1275.  
  1276.  
  1277.  
  1278. #endif
  1279.  
  1280. #if defined(S3000) && ~defined(DBL_MAX_10_EXP)
  1281.     l[0] = 0x7fffffff;
  1282.     l[1] = 0xffffffff;
  1283.     l[0] = 0x7fffffff;
  1284.     l[1] = 0xffffffff;
  1285.     biggest_float = *(float *)l;
  1286.     biggest_float = *(float *)l;
  1287.     biggest_float = *(float *)l;
  1288.     biggest_float = 0.0;
  1289.     biggest_float = biggest_float + 1.0;
  1290.     biggest_float = biggest_float + 2.0;
  1291.     biggest_float = *(float *)l;
  1292.     biggest_float = *(float *)l;
  1293.     strcmp("I don't like", "DATA GENERAL.");
  1294.     biggest_float = *(float *)l;
  1295.     biggest_double = *(double *)l;
  1296.     biggest_double = *(double *)l;
  1297.     biggest_double = *(double *)l;
  1298.     biggest_double = 0.0;
  1299.     biggest_double = biggest_double + 1.0;
  1300.     biggest_double = biggest_double + 2.0;
  1301.     biggest_double = *(double *)l;
  1302.     biggest_double = *(double *)l;
  1303.     strcmp("I don't like", "DATA GENERAL.");
  1304.     biggest_double = *(double *)l;
  1305. #endif
  1306.  
  1307.     
  1308. #ifdef DBL_MAX_10_EXP
  1309.     biggest_double = DBL_MAX;
  1310.     smallest_double = DBL_MIN;
  1311.     smallest_float = FLT_MIN;
  1312.     biggest_float = FLT_MAX;
  1313. #endif
  1314.     
  1315.  
  1316.  
  1317.  
  1318. /* We want the smallest number not satisfying something,
  1319.    and so we go quickly down, and then back up.  We have
  1320.    to use a function call for test, since in line code may keep
  1321.    too much precision, while the usual lisp eql,is not
  1322.    in line.
  1323.    We use SMALL as a multiple to come back up by.
  1324. */
  1325.  
  1326. #define SMALL 1.05    
  1327.     for (float_epsilon = 1.0;
  1328.          !SF_EQL((float)(1.0 + float_epsilon),(float)1.0);
  1329.          float_epsilon /= 2.0)
  1330.         ;
  1331.     while(SF_EQL((float)(1.0 + float_epsilon),(float)1.0))
  1332.       float_epsilon=float_epsilon*SMALL;
  1333.     for (float_negative_epsilon = 1.0;
  1334.          !SF_EQL((float)(1.0 - float_negative_epsilon) ,(float)1.0);
  1335.          float_negative_epsilon /= 2.0)
  1336.         ;
  1337.     while(SF_EQL((float)(1.0 - float_negative_epsilon) ,(float)1.0))
  1338.       float_negative_epsilon=float_negative_epsilon*SMALL;
  1339.     for (double_epsilon = 1.0;
  1340.          !(LF_EQL(1.0 + double_epsilon, 1.0));
  1341.          double_epsilon /= 2.0)
  1342.         ;
  1343.     while((LF_EQL(1.0 + double_epsilon, 1.0)))
  1344.       double_epsilon=double_epsilon*SMALL;
  1345.       ;
  1346.     for (double_negative_epsilon = 1.0;
  1347.          !LF_EQL(1.0 - double_negative_epsilon , 1.0);
  1348.          double_negative_epsilon /= 2.0)
  1349.         ;
  1350.     while(LF_EQL(1.0 - double_negative_epsilon , 1.0))
  1351.       double_negative_epsilon=double_negative_epsilon*SMALL;
  1352.       ;
  1353.     
  1354.  
  1355.     make_constant("MOST-POSITIVE-SHORT-FLOAT",
  1356.               make_shortfloat(biggest_float));
  1357.     make_constant("LEAST-POSITIVE-SHORT-FLOAT",
  1358.               make_shortfloat(smallest_float));
  1359.     make_constant("LEAST-NEGATIVE-SHORT-FLOAT",
  1360.               make_shortfloat(-smallest_float));
  1361.     make_constant("MOST-NEGATIVE-SHORT-FLOAT",
  1362.               make_shortfloat(-biggest_float));
  1363.  
  1364.     make_constant("MOST-POSITIVE-SINGLE-FLOAT",
  1365.               make_longfloat(biggest_double));
  1366.     make_constant("LEAST-POSITIVE-SINGLE-FLOAT",
  1367.               make_longfloat(smallest_double));
  1368.     make_constant("LEAST-NEGATIVE-SINGLE-FLOAT",
  1369.               make_longfloat(-smallest_double));
  1370.     make_constant("MOST-NEGATIVE-SINGLE-FLOAT",
  1371.               make_longfloat(-biggest_double));
  1372.  
  1373.     make_constant("MOST-POSITIVE-DOUBLE-FLOAT",
  1374.               make_longfloat(biggest_double));
  1375.     make_constant("LEAST-POSITIVE-DOUBLE-FLOAT",
  1376.               make_longfloat(smallest_double));
  1377.     make_constant("LEAST-NEGATIVE-DOUBLE-FLOAT",
  1378.               make_longfloat(-smallest_double));
  1379.     make_constant("MOST-NEGATIVE-DOUBLE-FLOAT",
  1380.               make_longfloat(-biggest_double));
  1381.  
  1382.     make_constant("MOST-POSITIVE-LONG-FLOAT",
  1383.               make_longfloat(biggest_double));
  1384.     make_constant("LEAST-POSITIVE-LONG-FLOAT",
  1385.               make_longfloat(smallest_double));
  1386.     make_constant("LEAST-NEGATIVE-LONG-FLOAT",
  1387.               make_longfloat(-smallest_double));
  1388.     make_constant("MOST-NEGATIVE-LONG-FLOAT",
  1389.               make_longfloat(-biggest_double));
  1390.  
  1391.     make_constant("SHORT-FLOAT-EPSILON",
  1392.               make_shortfloat(float_epsilon));
  1393.     make_constant("SINGLE-FLOAT-EPSILON",
  1394.               make_longfloat(double_epsilon));
  1395.     make_constant("DOUBLE-FLOAT-EPSILON",
  1396.               make_longfloat(double_epsilon));
  1397.     make_constant("LONG-FLOAT-EPSILON",
  1398.               make_longfloat(double_epsilon));
  1399.  
  1400.     make_constant("SHORT-FLOAT-NEGATIVE-EPSILON",
  1401.               make_shortfloat(float_negative_epsilon));
  1402.     make_constant("SINGLE-FLOAT-NEGATIVE-EPSILON",
  1403.               make_longfloat(double_negative_epsilon));
  1404.     make_constant("DOUBLE-FLOAT-NEGATIVE-EPSILON",
  1405.               make_longfloat(double_negative_epsilon));
  1406.     make_constant("LONG-FLOAT-NEGATIVE-EPSILON",
  1407.               make_longfloat(double_negative_epsilon));
  1408.  
  1409.     plus_half = make_ratio(small_fixnum(1), small_fixnum(2));
  1410.     enter_mark_origin(&plus_half);
  1411.  
  1412.     minus_half = make_ratio(small_fixnum(-1), small_fixnum(2));
  1413.     enter_mark_origin(&minus_half);
  1414.  
  1415.     make_function("FLOAT", Lfloat);
  1416.     make_function("NUMERATOR", Lnumerator);
  1417.     make_function("DENOMINATOR", Ldenominator);
  1418.     make_function("FLOOR", Lfloor);
  1419.     make_function("CEILING", Lceiling);
  1420.     make_function("TRUNCATE", Ltruncate);
  1421.     make_function("ROUND", Lround);
  1422.     make_function("MOD", Lmod);
  1423.     make_function("REM", Lrem);
  1424.     make_function("DECODE-FLOAT", Ldecode_float);
  1425.     make_function("SCALE-FLOAT", Lscale_float);
  1426.     make_function("FLOAT-RADIX", Lfloat_radix);
  1427.     make_function("FLOAT-SIGN", Lfloat_sign);
  1428.     make_function("FLOAT-DIGITS", Lfloat_digits);
  1429.     make_function("FLOAT-PRECISION", Lfloat_precision);
  1430.     make_function("INTEGER-DECODE-FLOAT", Linteger_decode_float);
  1431.     make_function("COMPLEX", Lcomplex);
  1432.     make_function("REALPART", Lrealpart);
  1433.     make_function("IMAGPART", Limagpart);
  1434. }
  1435.