← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to o/num_co.c

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

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