← Back to branch summary

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

« back to all changes in this revision

Viewing changes to o/num_log.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_log.c
 
1
 
 
2
/*
 
3
 Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
 
4
 
 
5
This file is part of GNU Common Lisp, herein referred to as GCL
 
6
 
 
7
GCL is free software; you can redistribute it and/or modify it under
 
8
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
 
9
the Free Software Foundation; either version 2, or (at your option)
 
10
any later version.
 
11
 
 
12
GCL is distributed in the hope that it will be useful, but WITHOUT
 
13
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 
14
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
 
15
License for more details.
 
16
 
 
17
You should have received a copy of the GNU Library General Public License 
 
18
along with GCL; see the file COPYING.  If not, write to the Free Software
 
19
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 
20
 
 
21
*/
 
22
 
 
23
/*
 
24
        Logical operations on number
 
25
*/
 
26
#define NEED_MP_H
 
27
#include <stdlib.h>
 
28
#include "include.h"
 
29
#include "num_include.h"
 
30
 
 
31
   
 
32
#ifdef GMP
 
33
#include "gmp_num_log.c"
 
34
#else
 
35
#include "pari_num_log.c"
 
36
#endif
 
37
 
 
38
 
 
39
static int
 
40
ior_op(int i, int j)
 
41
{
 
42
        return(i | j);
 
43
}
 
44
 
 
45
static int
 
46
xor_op(int i, int j)
 
47
{
 
48
        return(i ^ j);
 
49
}
 
50
 
 
51
static int
 
52
and_op(int i, int j)
 
53
{
 
54
        return(i & j);
 
55
}
 
56
 
 
57
static int
 
58
eqv_op(int i, int j)
 
59
{
 
60
        return(~(i ^ j));
 
61
}
 
62
 
 
63
static int
 
64
nand_op(int i, int j)
 
65
{
 
66
        return(~(i & j));
 
67
}
 
68
 
 
69
static int
 
70
nor_op(int i, int j)
 
71
{
 
72
        return(~(i | j));
 
73
}
 
74
 
 
75
static int
 
76
andc1_op(int i, int j)
 
77
{
 
78
        return((~i) & j);
 
79
}
 
80
 
 
81
static int
 
82
andc2_op(int i, int j)
 
83
{
 
84
        return(i & (~j));
 
85
}
 
86
 
 
87
static int
 
88
orc1_op(int i, int j)
 
89
{
 
90
        return((~i) | j);
 
91
}
 
92
 
 
93
static int
 
94
orc2_op(int i, int j)
 
95
{
 
96
        return(i | (~j));
 
97
}
 
98
 
 
99
static int
 
100
b_clr_op(int i, int j)
 
101
{
 
102
        return(0);
 
103
}
 
104
 
 
105
static int
 
106
b_set_op(int i, int j)
 
107
{
 
108
        return(-1);
 
109
}
 
110
 
 
111
static int
 
112
b_1_op(int i, int j)
 
113
{
 
114
        return(i);
 
115
}
 
116
 
 
117
static int
 
118
b_2_op(int i, int j)
 
119
{
 
120
        return(j);
 
121
}
 
122
 
 
123
static int
 
124
b_c1_op(int i, int j)
 
125
{
 
126
        return(~i);
 
127
}
 
128
 
 
129
static int
 
130
b_c2_op(int i, int j)
 
131
{
 
132
        return(~j);
 
133
}
 
134
 
 
135
#ifdef NEVER
 
136
int (*intLogOps)()[16]= {
 
137
  b_clr_op,  /* 0 */
 
138
  b_and_op,  /* 01 */
 
139
  b_andc2_op,  /* 02 */
 
140
  b_1_op,  /* 03 */
 
141
  b_andc1_op,  /* 04 */
 
142
  b_2_op,  /* 05 */
 
143
  b_xor_op,  /* 06 */
 
144
  b_ior_op,  /* 07 */
 
145
  b_nor_op,  /* 010 */
 
146
  b_eqv_op,  /* 011 */
 
147
  b_c2_op,  /* 012 */
 
148
  b_orc2_op,  /* 013 */
 
149
  b_c1_op,  /* 014 */
 
150
  b_orc1_op,  /* 015 */
 
151
  b_nand_op,  /* 016 */
 
152
  b_set_op,  /* 017 */
 
153
}
 
154
#endif
 
155
 
 
156
 
 
157
static int
 
158
fix_bitp(object x, int p)
 
159
{
 
160
        if (p > 30) {           /* fix = sign + bit0-30 */
 
161
                if (fix(x) < 0)
 
162
                        return(1);
 
163
                else
 
164
                        return(0);
 
165
        }
 
166
        return((fix(x) >> p) & 1);
 
167
}       
 
168
 
 
169
static int
 
170
count_int_bits(int x)
 
171
{
 
172
        int     i, count;
 
173
 
 
174
        count = 0;
 
175
        for (i=0; i <= 31; i++) count += ((x >> i) & 1);
 
176
        return(count);
 
177
}
 
178
 
 
179
static int
 
180
count_bits(object x)
 
181
{
 
182
        int i, count=0;
 
183
 
 
184
        if (type_of(x) == t_fixnum) {
 
185
                i = fix(x);
 
186
                if (i < 0) i = ~i;
 
187
                count = count_int_bits(i);
 
188
        } else if (type_of(x) == t_bignum)
 
189
          {
 
190
            count= MP_BITCOUNT(MP(x));
 
191
          }
 
192
        else 
 
193
                FEwrong_type_argument(sLinteger, x);
 
194
        return(count);
 
195
}
 
196
 
 
197
/*
 
198
        double_shift(h, l, w, hp, lp) shifts the int h & l ( 31 bits)
 
199
        w bits to left ( w > 0) or to right ( w < 0).
 
200
        result is returned in *hp and *lp.
 
201
*/
 
202
 
 
203
 
 
204
 
 
205
object
 
206
shift_integer(object x, int w)
 
207
{ 
 
208
  if (type_of(x) == t_fixnum)
 
209
    { if (w <= 0)
 
210
      {   w = -w;
 
211
          if (w >= WSIZ) return small_fixnum(fix(x) < 0 ? -1 :0);
 
212
          else
 
213
        return make_fixnum (fix(x) >> (w));}
 
214
    MPOP(return, shifti,SI_TO_MP(fix(x),big_fixnum1),w);
 
215
    }
 
216
  else
 
217
    if (type_of(x) == t_bignum) {
 
218
      MPOP(return,shifti,MP(x),w);
 
219
    }
 
220
  FEwrong_type_argument(sLinteger, x);
 
221
  return(Cnil);
 
222
}
 
223
        
 
224
 
 
225
static int
 
226
int_bit_length(int i)
 
227
{
 
228
        int     count, j;
 
229
 
 
230
        count = 0;
 
231
        for (j = 0; j <= 31 ; j++)
 
232
                if (((i >> j) & 1) == 1) count = j + 1;
 
233
        return(count);
 
234
}
 
235
 
 
236
 
 
237
 
 
238
LFD(Llogior)(void)
 
239
{
 
240
        object  x;
 
241
        int     narg, i;
 
242
        int     ior_op(int i, int j);
 
243
 
 
244
        narg = vs_top - vs_base;
 
245
        for (i = 0; i < narg; i++)
 
246
                check_type_integer(&vs_base[i]);
 
247
        if (narg == 0) {
 
248
                vs_top = vs_base;
 
249
                vs_push(small_fixnum(0));
 
250
                return;
 
251
        }
 
252
        if (narg == 1)
 
253
                return;
 
254
        x = log_op(ior_op,mp_ior_op);
 
255
        vs_top = vs_base;
 
256
        vs_push(x);
 
257
}
 
258
 
 
259
LFD(Llogxor)(void)
 
260
{
 
261
        object  x;
 
262
        int     narg, i;
 
263
        int     xor_op(int i, int j);
 
264
 
 
265
        narg = vs_top - vs_base;
 
266
        for (i = 0; i < narg; i++)
 
267
                check_type_integer(&vs_base[i]);
 
268
        if (narg == 0) {
 
269
                vs_top = vs_base;
 
270
                vs_push(small_fixnum(0));
 
271
                return;
 
272
        }
 
273
        if (narg == 1) return;
 
274
        x = log_op(xor_op,mp_xor_op);
 
275
        vs_top = vs_base;
 
276
        vs_push(x);
 
277
}
 
278
 
 
279
LFD(Llogand)(void)
 
280
{
 
281
        object  x;
 
282
        int     narg, i;
 
283
        int     and_op(int i, int j);
 
284
 
 
285
        narg = vs_top - vs_base;
 
286
        for (i = 0; i < narg; i++)
 
287
                check_type_integer(&vs_base[i]);
 
288
        if (narg == 0) {
 
289
                vs_top = vs_base;
 
290
                vs_push(small_fixnum(-1));
 
291
                return;
 
292
        }
 
293
        if (narg == 1) return;
 
294
        x = log_op(and_op,mp_and_op);
 
295
        vs_top = vs_base;
 
296
        vs_push(x);
 
297
}
 
298
 
 
299
LFD(Llogeqv)(void)
 
300
{
 
301
        object  x;
 
302
        int     narg, i;
 
303
        int     eqv_op(int i, int j);
 
304
 
 
305
        narg = vs_top - vs_base;
 
306
        for (i = 0; i < narg; i++)
 
307
                check_type_integer(&vs_base[i]);
 
308
        if (narg == 0) {
 
309
                vs_top = vs_base;
 
310
                vs_push(small_fixnum(-1));
 
311
                return;
 
312
        }
 
313
        if (narg == 1) return;
 
314
        x = log_op(eqv_op,mp_eqv_op);
 
315
        vs_top = vs_base;
 
316
        vs_push(x);
 
317
}
 
318
 
 
319
LFD(Lboole)(void)
 
320
{
 
321
        object  x;
 
322
        object  o;
 
323
        int     (*op)()=NULL;
 
324
        void    (*mp_op)() = (void *) 0;
 
325
 
 
326
        check_arg(3);
 
327
        check_type_integer(&vs_base[0]);
 
328
        check_type_integer(&vs_base[1]);
 
329
        check_type_integer(&vs_base[2]);
 
330
        o = vs_base[0];
 
331
 
 
332
        switch(fixint(o)) {
 
333
                case BOOLCLR:   op = b_clr_op; mp_op = mp_b_clr_op;     break;
 
334
                case BOOLSET:   op = b_set_op; mp_op = mp_b_set_op;     break;
 
335
                case BOOL1:     op = b_1_op; mp_op = mp_b_1_op; break;
 
336
                case BOOL2:     op = b_2_op; mp_op = mp_b_2_op; break;
 
337
                case BOOLC1:    op = b_c1_op; mp_op =mp_b_c1_op;        break;
 
338
                case BOOLC2:    op = b_c2_op; mp_op =mp_b_c2_op;        break;
 
339
                case BOOLAND:   op = and_op; mp_op = mp_and_op; break;
 
340
                case BOOLIOR:   op = ior_op; mp_op = mp_ior_op; break;
 
341
                case BOOLXOR:   op = xor_op; mp_op = mp_xor_op; break;
 
342
                case BOOLEQV:   op = eqv_op; mp_op = mp_eqv_op; break;
 
343
                case BOOLNAND:  op = nand_op; mp_op =mp_nand_op;        break;
 
344
                case BOOLNOR:   op = nor_op; mp_op = mp_nor_op; break;
 
345
                case BOOLANDC1: op = andc1_op; mp_op = mp_andc1_op;     break;
 
346
                case BOOLANDC2: op = andc2_op; mp_op = mp_andc2_op;     break;
 
347
                case BOOLORC1:  op = orc1_op; mp_op =mp_orc1_op;        break;
 
348
                case BOOLORC2:  op = orc2_op; mp_op =mp_orc2_op;        break;
 
349
                default:
 
350
                        FEerror("~S is an invalid logical operator.",
 
351
                                1, o);
 
352
        }
 
353
        vs_base++;
 
354
        x = log_op(op,mp_op);
 
355
        vs_base--;
 
356
        vs_top = vs_base;
 
357
        vs_push(x);
 
358
}
 
359
 
 
360
LFD(Llogbitp)(void)
 
361
{
 
362
        object  x, p;
 
363
        int     i;
 
364
 
 
365
        check_arg(2);
 
366
        check_type_integer(&vs_base[0]);
 
367
        check_type_integer(&vs_base[1]);
 
368
        p = vs_base[0];
 
369
        x = vs_base[1];
 
370
        if (type_of(p) == t_fixnum)
 
371
                if (type_of(x) == t_fixnum)
 
372
                        i = fix_bitp(x, fix(p));
 
373
                else
 
374
                        i = big_bitp(x, fix(p));
 
375
        else if (big_sign(p) < 0)
 
376
                        i = 0;
 
377
                /*
 
378
                   bit position represented by bignum is out of
 
379
                   our address space. So, result is returned
 
380
                   according to sign of integer.
 
381
                */
 
382
 
 
383
        else if (type_of(x) == t_fixnum)
 
384
                if (fix(x) < 0)
 
385
                        i = 1;
 
386
                else
 
387
                        i = 0;
 
388
        else if (big_sign(x) < 0)
 
389
                        i = 1;
 
390
                else
 
391
                        i = 0;
 
392
 
 
393
        vs_top = vs_base;
 
394
        if (i)
 
395
                vs_push(Ct);
 
396
        else
 
397
                vs_push(Cnil);
 
398
}
 
399
 
 
400
LFD(Lash)(void)
 
401
{
 
402
        object  r=Cnil, x, y;
 
403
        int     w, sign_x;
 
404
 
 
405
        check_arg(2);
 
406
        check_type_integer(&vs_base[0]);
 
407
        check_type_integer(&vs_base[1]);
 
408
        x = vs_base[0];
 
409
        y = vs_base[1];
 
410
        if (type_of(y) == t_fixnum) {
 
411
                w = fix(y);
 
412
                r = shift_integer(x, w);
 
413
        } else if (type_of(y) == t_bignum)
 
414
                goto LARGE_SHIFT;
 
415
        else
 
416
                ;
 
417
        goto BYE;
 
418
 
 
419
        /*
 
420
        bit position represented by bignum is probably
 
421
        out of our address space. So, result is returned
 
422
        according to sign of integer.
 
423
        */
 
424
LARGE_SHIFT:
 
425
        if (type_of(x) == t_fixnum)
 
426
                if (fix(x) > 0)
 
427
                        sign_x = 1;
 
428
                else if (fix(x) == 0)
 
429
                        sign_x = 0;
 
430
                else
 
431
                        sign_x = -1;
 
432
        else
 
433
                sign_x = big_sign(x);
 
434
        if (big_sign(y) < 0)
 
435
                if (sign_x < 0)
 
436
                        r = small_fixnum(-1);
 
437
                else
 
438
                        r = small_fixnum(0);
 
439
        else if (sign_x == 0)
 
440
                r = small_fixnum(0);
 
441
        else
 
442
                FEerror("Insufficient memory.", 0);
 
443
 
 
444
BYE:
 
445
        vs_top = vs_base;
 
446
        vs_push(r);
 
447
}
 
448
 
 
449
LFD(Llogcount)(void)
 
450
{
 
451
        object  x;
 
452
        int     i;
 
453
 
 
454
        check_arg(1);
 
455
        check_type_integer(&vs_base[0]);
 
456
        x = vs_base[0];
 
457
        i = count_bits(x);
 
458
        vs_top = vs_base;
 
459
        vs_push(make_fixnum(i));
 
460
}
 
461
 
 
462
LFD(Linteger_length)(void)
 
463
{
 
464
        object  x;
 
465
        int count=0, i;
 
466
 
 
467
        check_arg(1);
 
468
        x = vs_base[0];
 
469
        if (type_of(x) == t_fixnum) {
 
470
                i = fix(x);
 
471
                if (i < 0) i = ~i;
 
472
                count = int_bit_length(i);
 
473
        } else if (type_of(x) == t_bignum) 
 
474
          count = MP_SIZE_IN_BASE2(MP(x));
 
475
        else
 
476
                FEwrong_type_argument(sLinteger, x);
 
477
        vs_top = vs_base;
 
478
        vs_push(make_fixnum(count));
 
479
}
 
480
 
 
481
#define W_SIZE (8*sizeof(int))
 
482
/* static object */
 
483
/* bitand(object a, object b, object c) */
 
484
/* { int d= a->bv.bv_fillp; */
 
485
/*   int *ap,*bp,*cp; */
 
486
/*   d=(d+W_SIZE-1)/W_SIZE; */
 
487
/*   ap= (int *)(a->bv.bv_self); */
 
488
/*   bp= (int *)(b->bv.bv_self); */
 
489
/*   cp= (int *)(c->bv.bv_self); */
 
490
/*   while (--d >= 0) */
 
491
/*     { *cp++ = *bp++ & *ap++; */
 
492
/*     } */
 
493
/*   return c; */
 
494
/* } */
 
495
 
 
496
/* static object */
 
497
/* bitior(object a, object b, object c) */
 
498
/* { int *ap,*cp,*bp, d= a->bv.bv_fillp; */
 
499
/*   d=(d+W_SIZE-1)/W_SIZE; */
 
500
/*    ap= (int *)((a->bv.bv_self)); */
 
501
/*    bp= (int *)(b->bv.bv_self); */
 
502
/*    cp= (int *)(c->bv.bv_self); */
 
503
/*   while (--d >= 0) */
 
504
/*     { *cp++ = *bp++ | *ap++; */
 
505
/*     } */
 
506
/*   return c; */
 
507
/* } */
 
508
 
 
509
/* Note in order to be equal we assume that the part above the
 
510
   fill pointer is 0 up to the next word */
 
511
 
 
512
/* static int */
 
513
/* bvequal(object a, object b) */
 
514
/* { int *ap,*bp, d= a->bv.bv_fillp; */
 
515
/*   d=(d+W_SIZE-1)/W_SIZE; */
 
516
/*  ap= (int *)(a->bv.bv_self); */
 
517
/*  bp= (int *)(b->bv.bv_self); */
 
518
/*   while (--d >= 0) */
 
519
/*     { if (*ap++ != *bp++) return 1; */
 
520
/*     } */
 
521
/*   return 0; */
 
522
/* } */
 
523
 
 
524
  
 
525
 
 
526
LFD(siLbit_array_op)(void)
 
527
{
 
528
        int i, j, n, d;
 
529
        object  o, x, y, r, r0=Cnil;
 
530
        int (*op)()=NULL;
 
531
        bool replace = FALSE;
 
532
        int xi, yi, ri;
 
533
        char *xp, *yp, *rp;
 
534
        int xo, yo, ro;
 
535
        object *base = vs_base;
 
536
 
 
537
        check_arg(4);
 
538
        o = vs_base[0];
 
539
        x = vs_base[1];
 
540
        y = vs_base[2];
 
541
        r = vs_base[3];
 
542
        if (type_of(x) == t_bitvector) {
 
543
                d = x->bv.bv_dim;
 
544
                xp = x->bv.bv_self;
 
545
                xo = BV_OFFSET(x);
 
546
                if (type_of(y) != t_bitvector)
 
547
                        goto ERROR;
 
548
                if (d != y->bv.bv_dim)
 
549
                        goto ERROR;
 
550
                yp = y->bv.bv_self;
 
551
                yo = BV_OFFSET(y);
 
552
                if (r == Ct)
 
553
                        r = x;
 
554
                if (r != Cnil) {
 
555
                        if (type_of(r) != t_bitvector)
 
556
                                goto ERROR;
 
557
                        if (r->bv.bv_dim != d)
 
558
                                goto ERROR;
 
559
                        i = (r->bv.bv_self - xp)*8 + (BV_OFFSET(r) - xo);
 
560
                        if ((i > 0 && i < d) || (i < 0 && -i < d)) {
 
561
                                r0 = r;
 
562
                                r = Cnil;
 
563
                                replace = TRUE;
 
564
                                goto L1;
 
565
                        }
 
566
                        i = (r->bv.bv_self - yp)*8 + (BV_OFFSET(r) - yo);
 
567
                        if ((i > 0 && i < d) || (i < 0 && -i < d)) {
 
568
                                r0 = r;
 
569
                                r = Cnil;
 
570
                                replace = TRUE;
 
571
                        }
 
572
                }
 
573
        L1:
 
574
                if (r == Cnil) {
 
575
                        vs_base = vs_top;
 
576
                        vs_push(sLbit);
 
577
                        vs_push(make_fixnum(d));
 
578
                        vs_push(Cnil);
 
579
                        vs_push(Cnil);
 
580
                        vs_push(Cnil);
 
581
                        vs_push(Cnil);
 
582
                        vs_push(Cnil);
 
583
                        siLmake_vector();
 
584
                        r = vs_base[0];
 
585
                }
 
586
        } else {
 
587
                if (type_of(x) != t_array)
 
588
                        goto ERROR;
 
589
                if ((enum aelttype)x->a.a_elttype != aet_bit)
 
590
                        goto ERROR;
 
591
                d = x->a.a_dim;
 
592
                xp = x->bv.bv_self;
 
593
                xo = BV_OFFSET(x);
 
594
                if (type_of(y) != t_array)
 
595
                        goto ERROR;
 
596
                if ((enum aelttype)y->a.a_elttype != aet_bit)
 
597
                        goto ERROR;
 
598
                if (x->a.a_rank != y->a.a_rank)
 
599
                        goto ERROR;
 
600
                yp = y->bv.bv_self;
 
601
                yo = BV_OFFSET(y);
 
602
                for (i = 0;  i < x->a.a_rank;  i++)
 
603
                        if (x->a.a_dims[i] != y->a.a_dims[i])
 
604
                                goto ERROR;
 
605
                if (r == Ct)
 
606
                        r = x;
 
607
                if (r != Cnil) {
 
608
                        if (type_of(r) != t_array)
 
609
                                goto ERROR;
 
610
                        if ((enum aelttype)r->a.a_elttype != aet_bit)
 
611
                                goto ERROR;
 
612
                        if (r->a.a_rank != x->a.a_rank)
 
613
                                goto ERROR;
 
614
                        for (i = 0;  i < x->a.a_rank;  i++)
 
615
                                if (r->a.a_dims[i] != x->a.a_dims[i])
 
616
                                        goto ERROR;
 
617
                        i = (r->bv.bv_self - xp)*8 + (BV_OFFSET(r) - xo);
 
618
                        if ((i > 0 && i < d) || (i < 0 && -i < d)) {
 
619
                                r0 = r;
 
620
                                r = Cnil;
 
621
                                replace = TRUE;
 
622
                                goto L2;
 
623
                        } 
 
624
                        i = (r->bv.bv_self - yp)*8 + (BV_OFFSET(r) - yo);
 
625
                        if ((i > 0 && i < d) || (i < 0 && -i < d)) {
 
626
                                r0 = r;
 
627
                                r = Cnil;
 
628
                                replace = TRUE;
 
629
                        }
 
630
                }
 
631
        L2:
 
632
                if (r == Cnil) {
 
633
                  object b;
 
634
                  struct cons *p=alloca(x->a.a_rank*sizeof(struct cons));
 
635
                  if (x->a.a_rank) {
 
636
                    object b1;
 
637
 
 
638
                    b=(object)p;
 
639
                    for (b1=b,i=0;i<x->a.a_rank;i++,b1=b1->c.c_cdr) {
 
640
                      b1->d.t=(int)t_cons;
 
641
                      b1->d.m=FALSE;
 
642
                      b1->c.c_car=/* x->a.a_dims[i]<SMALL_FIXNUM_LIMIT ?  */
 
643
                        /* small_fixnum(x->a.a_dims[i]) :  */ 
 
644
                        /* now done in a macro */
 
645
                        make_fixnum(x->a.a_dims[i]);
 
646
                      b1->c.c_cdr=i<x->a.a_rank-1 ? (object)++p : Cnil;
 
647
                    }
 
648
                  } else
 
649
                    b=Cnil;
 
650
 
 
651
                  r = fSmake_array1(aet_bit,Cnil,small_fixnum(0),Cnil,0,b);
 
652
 
 
653
                  /*              object b[F_ARG_LIMIT]; */
 
654
                  /*              b[0]=Cnil; */
 
655
                  /*              for (i = 0;  i < x->a.a_rank;  i++) */
 
656
                  /*                b[i] = (make_fixnum(x->a.a_dims[i])); */
 
657
                  /*              r=Iapply_fun_n1(fSmake_array1,5,x->a.a_rank ? x->a.a_rank : 1, */
 
658
                  /*                           aet_bit, */
 
659
                  /*                           Cnil, */
 
660
                  /*                           small_fixnum(0), */
 
661
                  /*                           Cnil, */
 
662
                  /*                           Cnil, */
 
663
                  /*                             b); */
 
664
 
 
665
                }
 
666
        }
 
667
        rp = r->bv.bv_self;
 
668
        ro = BV_OFFSET(r);
 
669
        switch(fixint(o)) {
 
670
                case BOOLCLR:   op = b_clr_op;  break;
 
671
                case BOOLSET:   op = b_set_op;  break;
 
672
                case BOOL1:     op = b_1_op;    break;
 
673
                case BOOL2:     op = b_2_op;    break;
 
674
                case BOOLC1:    op = b_c1_op;   break;
 
675
                case BOOLC2:    op = b_c2_op;   break;
 
676
                case BOOLAND:   op = and_op;    break;
 
677
                case BOOLIOR:   op = ior_op;    break;
 
678
                case BOOLXOR:   op = xor_op;    break;
 
679
                case BOOLEQV:   op = eqv_op;    break;
 
680
                case BOOLNAND:  op = nand_op;   break;
 
681
                case BOOLNOR:   op = nor_op;    break;
 
682
                case BOOLANDC1: op = andc1_op;  break;
 
683
                case BOOLANDC2: op = andc2_op;  break;
 
684
                case BOOLORC1:  op = orc1_op;   break;
 
685
                case BOOLORC2:  op = orc2_op;   break;
 
686
                default:
 
687
                        FEerror("~S is an invalid logical operator.", 1, o);
 
688
        }
 
689
 
 
690
#define set_high(place, nbits, value) \
 
691
        ((place)=(((place)&~(-0400>>(nbits)))|((value)&(-0400>>(nbits)))))
 
692
 
 
693
#define set_low(place, nbits, value) \
 
694
        ((place)=(((place)&(-0400>>(8-(nbits))))|((value)&~(-0400>>(8-(nbits))))))
 
695
 
 
696
#define extract_byte(integer, pointer, index, offset) \
 
697
        (integer) = (pointer)[(index)+1] & 0377; \
 
698
        (integer) = ((pointer)[index]<<(offset))|((integer)>>(8-(offset)))
 
699
 
 
700
#define store_byte(pointer, index, offset, value) \
 
701
        set_low((pointer)[index], 8-(offset), (value)>>(offset)); \
 
702
        set_high((pointer)[(index)+1], offset, (value)<<(8-(offset)))
 
703
 
 
704
        if (xo == 0 && yo == 0 && ro == 0) {
 
705
                for (n = d/8, i = 0;  i < n;  i++)
 
706
                        rp[i] = (*op)(xp[i], yp[i]);
 
707
                if ((j = d%8) > 0)
 
708
                        set_high(rp[n], j, (*op)(xp[n], yp[n]));
 
709
                if (!replace) {
 
710
                        vs_top = vs_base = base;
 
711
                        vs_push(r);
 
712
                        return;
 
713
                }
 
714
        } else {
 
715
                for (n = d/8, i = 0;  i <= n;  i++) {
 
716
                        extract_byte(xi, xp, i, xo);
 
717
                        extract_byte(yi, yp, i, yo);
 
718
                        if (i == n) {
 
719
                                if ((j = d%8) == 0)
 
720
                                        break;
 
721
                                extract_byte(ri, rp, n, ro);
 
722
                                set_high(ri, j, (*op)(xi, yi));
 
723
                        } else
 
724
                                ri = (*op)(xi, yi);
 
725
                        store_byte(rp, i, ro, ri);
 
726
                }
 
727
                if (!replace) {
 
728
                        vs_top = vs_base = base;
 
729
                        vs_push(r);
 
730
                        return;
 
731
                }
 
732
        }
 
733
        rp = r0->bv.bv_self;
 
734
        ro = BV_OFFSET(r0);
 
735
        for (n = d/8, i = 0;  i <= n;  i++) {
 
736
                if (i == n) {
 
737
                        if ((j = d%8) == 0)
 
738
                                break;
 
739
                        extract_byte(ri, rp, n, ro);
 
740
                        set_high(ri, j, r->bv.bv_self[n]);
 
741
                } else
 
742
                        ri = r->bv.bv_self[i];
 
743
                store_byte(rp, i, ro, ri);
 
744
        }
 
745
        vs_top = vs_base = base;
 
746
        vs_push(r0);
 
747
        return;
 
748
 
 
749
ERROR:
 
750
        FEerror("Illegal arguments for bit-array operation.", 0);
 
751
}
 
752
 
 
753
void
 
754
gcl_init_num_log(void)
 
755
{
 
756
/*      int siLbit_array_op(void); */
 
757
 
 
758
        make_constant("BOOLE-CLR", make_fixnum(BOOLCLR));
 
759
        make_constant("BOOLE-SET", make_fixnum(BOOLSET));
 
760
        make_constant("BOOLE-1", make_fixnum(BOOL1));
 
761
        make_constant("BOOLE-2", make_fixnum(BOOL2));
 
762
        make_constant("BOOLE-C1", make_fixnum(BOOLC1));
 
763
        make_constant("BOOLE-C2", make_fixnum(BOOLC2));
 
764
        make_constant("BOOLE-AND", make_fixnum(BOOLAND));
 
765
        make_constant("BOOLE-IOR", make_fixnum(BOOLIOR));
 
766
        make_constant("BOOLE-XOR", make_fixnum(BOOLXOR));
 
767
        make_constant("BOOLE-EQV", make_fixnum(BOOLEQV));
 
768
        make_constant("BOOLE-NAND", make_fixnum(BOOLNAND));
 
769
        make_constant("BOOLE-NOR", make_fixnum(BOOLNOR));
 
770
        make_constant("BOOLE-ANDC1", make_fixnum(BOOLANDC1));
 
771
        make_constant("BOOLE-ANDC2", make_fixnum(BOOLANDC2));
 
772
        make_constant("BOOLE-ORC1", make_fixnum(BOOLORC1));
 
773
        make_constant("BOOLE-ORC2", make_fixnum(BOOLORC2));
 
774
 
 
775
        make_function("LOGIOR", Llogior);
 
776
        make_function("LOGXOR", Llogxor);
 
777
        make_function("LOGAND", Llogand);
 
778
        make_function("LOGEQV", Llogeqv);
 
779
        make_function("BOOLE", Lboole);
 
780
        make_function("LOGBITP", Llogbitp);
 
781
        make_function("ASH", Lash);
 
782
        make_function("LOGCOUNT", Llogcount);
 
783
        make_function("INTEGER-LENGTH", Linteger_length);
 
784
 
 
785
        sLbit = make_ordinary("BIT");
 
786
        make_si_function("BIT-ARRAY-OP", siLbit_array_op);
 
787
}
 
788