← Back to branch summary

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

« back to all changes in this revision

Viewing changes to o/array.c1

  • 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/array.c1
 
1
/*
 
2
 Copyright (C) 1994  W. Schelter
 
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
#include "include.h"
 
23
 
 
24
 
 
25
#define ARRAY_DIMENSION_LIMIT MOST_POSITIVE_FIXNUM
 
26
 
 
27
DEFCONST("ARRAY-RANK-LIMIT", sLarray_rank_limit, LISP,
 
28
         make_fixnum(ARRAY_RANK_LIMIT),"");
 
29
 
 
30
DEFCONST("ARRAY-DIMENSION-LIMIT", sLarray_dimension_limit,
 
31
         LISP, make_fixnum(MOST_POSITIVE_FIX),"");
 
32
DEFCONST("ARRAY-TOTAL-SIZE-LIMIT", sLarray_total_size_limit,
 
33
         LISP, sLarray_dimension_limit,"");
 
34
 
 
35
DEF_ORDINARY("BIT",sLbit,LISP,"");
 
36
 
 
37
/* number of bits in  unit of storage of x->bv.bv_self[0] */
 
38
 
 
39
#define BV_BITS 8
 
40
 
 
41
#define BITREF(x,i) \
 
42
  ((((1 << (BV_BITS -1)) >> (i % BV_BITS)) & (x->bv.bv_self[i/BV_BITS])) \
 
43
   ? 1 : 0)
 
44
 
 
45
#define SET_BITREF(x,i) \
 
46
  (x->bv.bv_self[i/BV_BITS]) |= ((1 << (BV_BITS -1)) >> (i % BV_BITS))
 
47
#define CLEAR_BITREF(x,i) \
 
48
  (x->bv.bv_self[i/BV_BITS]) &= ~(((1 << (BV_BITS -1)) >> (i % BV_BITS)))
 
49
 
 
50
extern short aet_sizes[];
 
51
 
 
52
#define ARRAY_BODY_PTR(ar,n) \
 
53
  (void *)(ar->ust.ust_self + aet_sizes[Iarray_element_type(ar)]*n)
 
54
 
 
55
#define N_FIXNUM_ARGS 6
 
56
 
 
57
DEFUNO("AREF", object, fLaref, LISP, 1, ARRAY_RANK_LIMIT,
 
58
       NONE, OO, II, II, II,Laref,"")
 
59
(x, i, va_alist)
 
60
  object x;
 
61
  int i;
 
62
  va_dcl
 
63
{ int n = VFUN_NARGS;
 
64
  int i1;
 
65
  va_list ap;
 
66
  if (type_of(x) == t_array)
 
67
    {int m,k ;
 
68
     int rank = n - 1; 
 
69
     if (x->a.a_rank != rank)
 
70
       FEerror(" ~a has wrong rank",1,x);
 
71
     if (rank == 1) return fSaref1(x,i);
 
72
     if (rank == 0) return fSaref1(x,0);
 
73
     va_start(ap);
 
74
     m = 0;
 
75
     k = i;
 
76
     /* index into 1 dimensional array */
 
77
     i1 = 0;
 
78
     rank-- ;
 
79
     while(1) 
 
80
       {
 
81
         if (k >= x->a.a_dims[m])
 
82
           FEerror("Index ~a to array is too large",1,make_fixnum (m));
 
83
         i1 += k;
 
84
         m ++;
 
85
         if (m <= rank)
 
86
           { i1 = i1 * x->a.a_dims[m];
 
87
             if (m < N_FIXNUM_ARGS)
 
88
               { k = va_arg(ap,int);}
 
89
             else {object x = va_arg(ap,object);
 
90
                   check_type(x,t_fixnum);
 
91
                   k = Mfix(x);}
 
92
          
 
93
           }
 
94
         else break;}
 
95
     va_end(ap);
 
96
     return fSaref1(x,i1);
 
97
   }
 
98
  if (n > 2)
 
99
    { FEerror("Too many args (~a) to aref",1,make_fixnum(n));}
 
100
  return fSaref1(x,i);
 
101
 
 
102
}
 
103
 
 
104
int
 
105
fScheck_bounds_bounds(x, i)
 
106
  object x;
 
107
  int i;
 
108
{
 
109
  switch (type_of(x)) {
 
110
  case t_array:
 
111
  case t_vector:
 
112
  case t_string:
 
113
    if ((unsigned int) i >= x->a.a_dim)
 
114
    FEerror("Array ref out of bounds ~a ~a", 2, x, make_fixnum(i));
 
115
  default:
 
116
    FEerror("not an array");
 
117
  }
 
118
}
 
119
 
 
120
DEFUN("SVREF", object, fLsvref, LISP, 2, 2,
 
121
      ONE_VAL, OO, IO, OO,OO,
 
122
      "For array X and index I it returns (aref x i) ")
 
123
     (x, i)
 
124
     object x;
 
125
     unsigned int i;
 
126
{
 
127
 if (type_of(x)==t_vector
 
128
     && (enum aelttype)x->v.v_elttype == aet_object
 
129
     && x->v.v_dim > i)
 
130
   RETURN1(x->v.v_self[i]);
 
131
 if (x->v.v_dim > i) illegal_index(x,make_fixnum(i));
 
132
 FEerror("Bad simple vector ~a",1,x);
 
133
}
 
134
    
 
135
DEFUN("AREF1", object, fSaref1, SI, 2, 2,
 
136
      NONE, OO, IO, OO,OO,
 
137
      "For array X and index I it returns (aref x i) as if x were \
 
138
1 dimensional, even though its rank may be bigger than 1")
 
139
(x, i)
 
140
  object x;
 
141
  int i;
 
142
{
 
143
  switch (type_of(x)) {
 
144
  case t_array:
 
145
  case t_vector:
 
146
  case t_bitvector:
 
147
    if (x->v.v_dim <= i)
 
148
      i = fScheck_bounds_bounds(x, i);
 
149
    switch (x->v.v_elttype) {
 
150
    case aet_object:
 
151
      return x->v.v_self[i];
 
152
    case aet_ch:
 
153
      return code_char(x->st.st_self[i]);
 
154
    case aet_bit:
 
155
      i += x->bv.bv_offset;
 
156
      return make_fixnum(BITREF(x, i));
 
157
    case aet_fix:
 
158
      return make_fixnum(x->fixa.fixa_self[i]);
 
159
    case aet_sf:
 
160
      return make_longfloat(x->sfa.sfa_self[i]);
 
161
    case aet_lf:
 
162
      return make_longfloat(x->lfa.lfa_self[i]);
 
163
    case aet_char:
 
164
      return make_fixnum(x->st.st_self[i]);
 
165
    case aet_uchar:
 
166
      return make_fixnum(x->ust.ust_self[i]);
 
167
    case aet_short:
 
168
      return make_fixnum(SHORT(x, i));
 
169
    case aet_ushort:
 
170
      return make_fixnum(USHORT(x, i));
 
171
 
 
172
    default:
 
173
      FEerror("unknown array type");
 
174
    }
 
175
  case t_string:
 
176
    if (x->v.v_dim <= i)
 
177
      i = fScheck_bounds_bounds(x, i);
 
178
    return code_char(x->st.st_self[i]);
 
179
  default:
 
180
    FEerror("not an array");
 
181
 
 
182
    ;
 
183
  }
 
184
}
 
185
 
 
186
DEFUN("ASET1", object, fSaset1, SI, 3, 3, NONE, OO, IO, OO,OO,"")
 
187
(x, i,val)
 
188
  object x;
 
189
  int i;
 
190
  object val;
 
191
{
 
192
  switch (type_of(x)) {
 
193
  case t_array:
 
194
  case t_vector:
 
195
  case t_bitvector:
 
196
    if (x->v.v_dim <= i)
 
197
      i = fScheck_bounds_bounds(x, i);
 
198
    switch (x->v.v_elttype) {
 
199
    case aet_object:
 
200
      x->v.v_self[i] = val;
 
201
      break;
 
202
    case aet_ch:
 
203
      ASSURE_TYPE(val,t_character);
 
204
      x->st.st_self[i] = char_code(val);
 
205
      break;
 
206
    case aet_bit:
 
207
      i += x->bv.bv_offset;
 
208
    AGAIN_BIT: 
 
209
      ASSURE_TYPE(val,t_fixnum);
 
210
      {int v = Mfix(val);
 
211
       if (v == 0) CLEAR_BITREF(x,i);
 
212
       else if (v == 1) SET_BITREF(x,i);
 
213
       else {val= fSincorrect_type(val,sLbit);
 
214
             goto AGAIN_BIT;}
 
215
       break;}
 
216
    case aet_fix:
 
217
      ASSURE_TYPE(val,t_fixnum);
 
218
      (x->fixa.fixa_self[i]) = Mfix(val);
 
219
      break;
 
220
    case aet_sf:
 
221
      ASSURE_TYPE(val,t_shortfloat);
 
222
      (x->sfa.sfa_self[i]) = Msf(val);
 
223
      break;
 
224
    case aet_lf:
 
225
      ASSURE_TYPE(val,t_longfloat);
 
226
      (x->lfa.lfa_self[i]) = Mlf(val);
 
227
      break;
 
228
    case aet_char:
 
229
      ASSURE_TYPE(val,t_fixnum);
 
230
      x->st.st_self[i] = Mfix(val);
 
231
      break;
 
232
    case aet_uchar:
 
233
      ASSURE_TYPE(val,t_fixnum);
 
234
      (x->ust.ust_self[i])= Mfix(val);
 
235
      break;
 
236
    case aet_short:
 
237
      ASSURE_TYPE(val,t_fixnum);
 
238
      SHORT(x, i) = Mfix(val);
 
239
      break;
 
240
    case aet_ushort:
 
241
      ASSURE_TYPE(val,t_fixnum);
 
242
      USHORT(x, i) = Mfix(val);
 
243
      break;
 
244
    default:
 
245
      FEerror("unknown array type");
 
246
    }
 
247
    break;
 
248
  case t_string:
 
249
    if (x->v.v_dim <= i)
 
250
      i = fScheck_bounds_bounds(x, i);
 
251
    ASSURE_TYPE(val,t_character);
 
252
    x->st.st_self[i] = char_code(val);
 
253
    break;
 
254
  default:
 
255
    FEerror("not an array",0);
 
256
  }
 
257
  return val;
 
258
}
 
259
 
 
260
DEFUNO("ASET", object, fSaset, SI, 1, ARG_LIMIT, NONE, OO,
 
261
       OO, OO, OO,siLaset,"")
 
262
 (x,ii,y, va_alist)
 
263
  object x,y;
 
264
  object ii;
 
265
  va_dcl
 
266
{ int i1;
 
267
  int n = VFUN_NARGS;
 
268
  int i;
 
269
  va_list ap;
 
270
  if (type_of(x) == t_array)
 
271
    {int m,k ;
 
272
     int rank = n - 2; 
 
273
     if (x->a.a_rank != rank)
 
274
       FEerror(" ~a has wrong rank",x);
 
275
     if (rank == 0) return fSaset1(x,0,ii);
 
276
     ASSURE_TYPE(ii,t_fixnum);
 
277
     i = fix(ii);
 
278
     if (rank == 1)
 
279
       return fSaset1(x,i,y);
 
280
     va_start(ap);
 
281
     m = 0;
 
282
     k = i;
 
283
     /* index into 1 dimensional array body */
 
284
     i1 = 0;
 
285
     rank-- ;
 
286
     while(1) 
 
287
       {
 
288
         if (k >= x->a.a_dims[m])
 
289
           FEerror("Index ~a to array is too large",1,make_fixnum (m));
 
290
         i1 += k;
 
291
         if (m < rank)
 
292
           {object u;
 
293
            if (m == 0)
 
294
              { u = y;}
 
295
            else
 
296
              { u = va_arg(ap,object);}
 
297
            check_type(u,t_fixnum);
 
298
            k = Mfix(u);
 
299
            m++ ;
 
300
            i1 = i1 * x->a.a_dims[m];
 
301
 
 
302
          }
 
303
         else
 
304
           { y = va_arg(ap,object);
 
305
             break ;}
 
306
       }
 
307
     va_end(ap);
 
308
   }
 
309
  else 
 
310
    { ASSURE_TYPE(ii,t_fixnum);
 
311
     i1 = fix(ii);
 
312
      }
 
313
  return fSaset1(x,i1,y);
 
314
   
 
315
}
 
316
 
 
317
DEFUNO("SVSET", object, fSsvset, SI, 3, 3, NONE, OO, IO, OO,
 
318
       OO,siLsvset,"")
 
319
     (x,i,val)
 
320
     object x,val;
 
321
     int i;
 
322
{ if (TYPE_OF(x) != t_vector
 
323
      || DISPLACED_TO(x) != Cnil)
 
324
    Wrong_type_error("simple array",0);
 
325
  if (i > x->v.v_dim)
 
326
    { FEerror("out of bounds",0);
 
327
    }
 
328
  return x->v.v_self[i] = val;
 
329
}
 
330
  
 
331
/*
 
332
(proclaim '(ftype (function (fixnum fixnum t  *)) make-vector1))
 
333
(defun make-vector1 (n elt-type staticp &optional fillp initial-element
 
334
                     displaced-to (displaced-index-offset  0))
 
335
  (declare (fixnum n elt-type displaced-index-offset))
 
336
*/ 
 
337
 
 
338
 
 
339
DEFUN("MAKE-VECTOR1",object,fSmake_vector1,SI,3,8,NONE,OI,
 
340
      IO,OO,OO,"")
 
341
  (n,elt_type,staticp,va_alist)
 
342
int n;int elt_type;object staticp;va_dcl 
 
343
{ 
 
344
    int  displaced_index_offset;
 
345
    int Inargs = VFUN_NARGS - 3;
 
346
    va_list Iap;object fillp;object initial_element;object displaced_to;object V9;
 
347
    object V10,V11,V12,V13,V14;
 
348
    Inargs = VFUN_NARGS - 3 ;
 
349
    { object x;
 
350
      BEGIN_NO_INTERRUPT;
 
351
      switch(elt_type) {
 
352
      case aet_ch:
 
353
        x = alloc_object(t_string);
 
354
        goto a_string;
 
355
        break;
 
356
      case aet_bit:
 
357
        x = alloc_object(t_bitvector);
 
358
        break;
 
359
      default:
 
360
        x = alloc_object(t_vector);}
 
361
      x->v.v_elttype = elt_type;
 
362
    a_string:
 
363
      x->v.v_dim = n;
 
364
      x->v.v_self = 0;
 
365
      x->v.v_displaced = Cnil;
 
366
          
 
367
      if( --Inargs < 0)goto LA1;
 
368
      else {
 
369
        va_start(Iap);
 
370
        fillp=va_arg(Iap,object);
 
371
        if (fillp == Cnil)
 
372
          {x->v.v_hasfillp = 0;
 
373
           x->v.v_fillp = n;
 
374
         }
 
375
        else 
 
376
          if(type_of(fillp) == t_fixnum)
 
377
          {     
 
378
            x->v.v_fillp = Mfix(fillp);
 
379
            if (x->v.v_fillp > n) FEerror("bad fillp",0);
 
380
            x->v.v_hasfillp = 1;
 
381
          }
 
382
        else
 
383
          {
 
384
            x->v.v_fillp = n;
 
385
            x->v.v_hasfillp = 1;
 
386
          }
 
387
 
 
388
      }
 
389
 
 
390
      if( --Inargs < 0)goto LA2;
 
391
      else {
 
392
        initial_element=va_arg(Iap,object);}
 
393
 
 
394
      if( --Inargs < 0)goto LA4;
 
395
      else {
 
396
        displaced_to=va_arg(Iap,object);}
 
397
 
 
398
      if( --Inargs < 0)goto LA5;
 
399
      else {
 
400
        V9=va_arg(Iap,object);
 
401
        if (displaced_to != Cnil)
 
402
          { 
 
403
          ASSURE_TYPE(V9,t_fixnum);
 
404
          displaced_index_offset=Mfix(V9);}}
 
405
      goto LA6;
 
406
 
 
407
    LA1: 
 
408
      x->v.v_hasfillp = 0;
 
409
      x->v.v_fillp = n;  
 
410
    LA2: 
 
411
      initial_element=Cnil;
 
412
    LA4: 
 
413
      displaced_to=Cnil;
 
414
    LA5: 
 
415
      displaced_index_offset= 0;
 
416
    LA6:
 
417
      x->v.v_adjustable = 1;
 
418
      va_end(Iap);
 
419
      { if (displaced_to == Cnil)
 
420
          array_allocself(x,staticp!=Cnil,initial_element);
 
421
        else { displace(x,displaced_to,displaced_index_offset);}
 
422
        END_NO_INTERRUPT;
 
423
 
 
424
        return x;
 
425
      }
 
426
    }
 
427
  }
 
428
 
 
429
 
 
430
 
 
431
static object DFLT_aet_object = Cnil;   
 
432
static char DFLT_aet_ch = ' ';
 
433
static char DFLT_aet_char = 0; 
 
434
static int DFLT_aet_fix = 0  ;          
 
435
static short DFLT_aet_short = 0;
 
436
static shortfloat DFLT_aet_sf = 0.0;
 
437
static longfloat DFLT_aet_lf = 0.0;     
 
438
static object Iname_t = sLt;
 
439
struct { char * dflt; object *namep;} aet_types[] =
 
440
{   (char *)    &DFLT_aet_object,       &Iname_t,       /*  t  */
 
441
    (char *)    &DFLT_aet_ch, &sLstring_char,/*  string-char  */
 
442
    (char *)    &DFLT_aet_fix, &sLbit,          /*  bit  */
 
443
    (char *)    &DFLT_aet_fix,  &sLfixnum,      /*  fixnum  */
 
444
    (char *)    &DFLT_aet_sf, &sLshort_float,                   /*  short-float  */
 
445
    (char *)    &DFLT_aet_lf, &sLlong_float,    /*  long-float  */
 
446
    (char *)    &DFLT_aet_char,&sLsigned_char,               /* signed char */
 
447
    (char *)    &DFLT_aet_char,&sLunsigned_char,               /* unsigned char */
 
448
    (char *)    &DFLT_aet_short,&sLsigned_short,              /* signed short */
 
449
    (char *)    &DFLT_aet_short, &sLunsigned_short    /*  unsigned short   */
 
450
        };
 
451
 
 
452
DEFUN("GET-AELTTYPE",enum aelttype,fSget_aelttype,SI,1,1,NONE,IO,OO,OO,OO,"")
 
453
     (x)
 
454
object x;
 
455
{ int i;
 
456
  for (i=0 ; i <   aet_last ; i++)
 
457
    if (x == * aet_types[i].namep)
 
458
      return (enum aelttype) i;
 
459
  if (x == sLlong_float || x == sLsingle_float || x == sLdouble_float)
 
460
    return aet_lf;
 
461
  return aet_object;
 
462
}
 
463
 
 
464
/* backward compatibility only:
 
465
        (si:make-vector element-type 0
 
466
        dimension 1
 
467
        adjustable 2
 
468
        fill-pointer 3
 
469
        displaced-to 4
 
470
        displaced-index-offset 5
 
471
        static 6 &optional initial-element)
 
472
*/
 
473
DEFUNO("MAKE-VECTOR",object,fSmake_vector,SI,7,8,NONE,
 
474
       OO,OO,OO,OO,siLmake_vector,"")(x0,x1,x2,x3,x4,x5,x6,va_alist)
 
475
object x0,x1,x2,x3,x4,x5,x6;
 
476
va_dcl
 
477
{int narg=VFUN_NARGS;
 
478
 object initial_elt;
 
479
 va_list ap;
 
480
 object x;
 
481
 {va_start(ap);
 
482
 if (narg>=8) initial_elt=va_arg(ap,object);else goto LDEFAULT8;
 
483
 goto LEND_VARARG;
 
484
 LDEFAULT8: initial_elt = Cnil ;
 
485
 LEND_VARARG: va_end(ap);}
 
486
 
 
487
  /* 8 args */
 
488
 
 
489
  VFUN_NARGS = 8;
 
490
  x = fSmake_vector1(Mfix(x1),  /* n */
 
491
                     fSget_aelttype(x0), /*aelt type */
 
492
                     x6, /* staticp */
 
493
                     x3, /* fillp */ 
 
494
                     initial_elt, /* initial element */
 
495
                     x4,       /*displaced to */
 
496
                     x5);       /* displaced-index offset */
 
497
  x0 = x;
 
498
  RETURN1(x0);
 
499
}
 
500
 
 
501
/*
 
502
(proclaim '(ftype (function (fixnum t  *)) make-array1))
 
503
(defun make-array1 ( elt-type staticp  initial-element
 
504
                     displaced-to displaced-index-offset &optional dim1 dim2 .. )
 
505
  (declare (fixnum n elt-type displaced-index-offset))
 
506
*/
 
507
 
 
508
DEFUN("MAKE-ARRAY1",object,fSmake_array1,SI,6,6,
 
509
      NONE,OI,OO,OI,OO,"")
 
510
  (elt_type,staticp,initial_element,displaced_to, displaced_index_offset,
 
511
   dimensions)
 
512
 int elt_type;
 
513
 object staticp,initial_element,displaced_to;
 
514
 int displaced_index_offset;
 
515
 object dimensions;
 
516
{   
 
517
  int rank = length(dimensions);
 
518
  { object x,v;
 
519
    char *tmp_alloc;
 
520
    int dim =1,i; 
 
521
    BEGIN_NO_INTERRUPT;
 
522
    x = alloc_object(t_array);
 
523
    x->a.a_elttype = elt_type;
 
524
    x->a.a_self = 0;
 
525
    x->a.a_rank = rank;
 
526
    x->a.a_displaced = Cnil;
 
527
    x->a.a_dims = AR_ALLOC(alloc_relblock,rank,int);
 
528
    i = 0;
 
529
    v = dimensions;
 
530
    while (i < rank)
 
531
      { x->a.a_dims[i] = FIX_CHECK(Mcar(v));
 
532
        dim *= x->a.a_dims[i++];
 
533
        v = Mcdr(v);}
 
534
    x->a.a_dim = dim;
 
535
    x->a.a_adjustable = 1;
 
536
    { if (displaced_to == Cnil)
 
537
        array_allocself(x,staticp!=Cnil,initial_element);
 
538
    else { displace(x,displaced_to,displaced_index_offset);}
 
539
      END_NO_INTERRUPT;
 
540
        return x;
 
541
      }
 
542
 }}
 
543
      
 
544
 
 
545
 
 
546
 
 
547
 
 
548
  
 
549
 
 
550
 
 
551
/*
 
552
 (setq a (make-array 2 :displaced-to (setq b (make-array 4 ))))
 
553
                ;{  A->displ = (B), B->displ=(nil A)}
 
554
(setq w (make-array 3))   ;; w->displaced= (nil y u) 
 
555
(setq y (make-array 2 :displaced-to  w))  ;; y->displaced=(w z z2)
 
556
(setq u (make-array 2 :displaced-to w))   ;; u->displaced = (w)
 
557
(setq z (make-array 2 :displaced-to y))   ;; z->displaced = (y)
 
558
(setq z2 (make-array 2 :displaced-to y))  ;; z2->displaced= (y)
 
559
*/
 
560
 
 
561
displace(from_array,dest_array,offset)
 
562
     object from_array,dest_array;
 
563
     int offset;
 
564
{
 
565
  enum aelttype typ;
 
566
  IisArray(from_array);
 
567
  IisArray(dest_array);
 
568
  typ =Iarray_element_type(from_array);
 
569
  if (typ != Iarray_element_type(dest_array))
 
570
    { Wrong_type_error("same element type",0);
 
571
    }
 
572
  if (offset + from_array->a.a_dim > dest_array->a.a_dim)
 
573
    { FEerror("Destination array too small to hold other array",0);
 
574
    }
 
575
  /* ensure that we have a cons */
 
576
  if (dest_array->a.a_displaced == Cnil)
 
577
    { dest_array->a.a_displaced = list(2,Cnil,from_array);}
 
578
  else
 
579
    Mcdr(dest_array->a.a_displaced) = make_cons(from_array,
 
580
                                            Mcdr(dest_array->a.a_displaced));
 
581
  from_array->a.a_displaced = make_cons(dest_array,sLnil);
 
582
 
 
583
  /* now set the actual body of from_array to be the address
 
584
    of body in dest_array.  If it is a bit array, this cannot carry the
 
585
    offset information, since the body is only recorded as multiples of
 
586
    BV_BITS
 
587
  */
 
588
  
 
589
    
 
590
  if (typ == aet_bit)
 
591
    { offset += dest_array->bv.bv_offset;
 
592
      from_array->bv.bv_self = dest_array->bv.bv_self + offset/BV_BITS;
 
593
      from_array->bv.bv_offset = offset % BV_BITS;
 
594
    }
 
595
  else
 
596
    from_array->a.a_self = ARRAY_BODY_PTR(dest_array,offset);
 
597
  
 
598
}
 
599
    
 
600
 
 
601
 
 
602
enum aelttype
 
603
Iarray_element_type(x)
 
604
     object x;
 
605
{enum aelttype t;
 
606
  switch(TYPE_OF(x))
 
607
    { case t_array:
 
608
         t = (enum aelttype) x->a.a_elttype;
 
609
         break;
 
610
       case t_vector:
 
611
         t = (enum aelttype) x->v.v_elttype;
 
612
         break;
 
613
       case t_bitvector:
 
614
         t = aet_bit;
 
615
         break;
 
616
       case t_string:
 
617
         t = aet_ch;
 
618
         break;
 
619
       default:
 
620
         FEerror("Not an array ~a ",1,x);
 
621
       }
 
622
  return t;
 
623
}
 
624
 
 
625
   /* Make the body of FROM array point to the body of TO
 
626
      at the  DISPLACED_INDEX_OFFSET
 
627
      */
 
628
 
 
629
Idisplace_array(from,to,displaced_index_offset)
 
630
     object from,to;
 
631
     int displaced_index_offset;
 
632
{
 
633
  enum aelttype t1,t2;
 
634
  object tail;
 
635
  t1 = Iarray_element_type(from);
 
636
  t2 = Iarray_element_type(to);
 
637
  if (t1 != t2)
 
638
    FEerror("Attempt to displace arrays of one type to arrays of another type",0);
 
639
  if (to->a.a_dim > from->a.a_dim - displaced_index_offset)
 
640
    FEerror("To array not large enough for displacement",0);
 
641
  {BEGIN_NO_INTERRUPT;
 
642
   from->a.a_displaced = make_cons(to,Cnil);
 
643
   if (to->a.a_displaced == Cnil)
 
644
     to->a.a_displaced = make_cons(Cnil,Cnil);
 
645
   DISPLACED_FROM(to) = make_cons(from,DISPLACED_FROM(to));
 
646
       
 
647
   if (t1 == aet_bit) {
 
648
     displaced_index_offset += to->bv.bv_offset;
 
649
     from->bv.bv_self = to->bv.bv_self + displaced_index_offset/BV_BITS;
 
650
     from->bv.bv_offset = displaced_index_offset%BV_BITS;
 
651
   }
 
652
   else
 
653
     from->st.st_self = ARRAY_BODY_PTR(to,displaced_index_offset);
 
654
   END_NO_INTERRUPT;
 
655
 }
 
656
 
 
657
}
 
658
 
 
659
/* add diff to body of x and arrays diisplaced to it */
 
660
 
 
661
adjust_displaced(x, diff)
 
662
object x;
 
663
int diff;
 
664
{
 
665
        if (x->ust.ust_self != NULL)
 
666
                x->ust.ust_self = (char *)((int)(x->a.a_self) + diff);
 
667
        for (x = Mcdr(x->ust.ust_displaced);  x != Cnil;  x = Mcdr(x))
 
668
                adjust_displaced(Mcar(x), diff);
 
669
}
 
670
 
 
671
 
 
672
 
 
673
 
 
674
   /* RAW_AET_PTR returns a pointer to something of raw type obtained from X
 
675
      suitable for using GSET for an array of elt type TYP.
 
676
      If x is the null pointer, return a default for that array element
 
677
      type.
 
678
      */
 
679
 
 
680
char *
 
681
raw_aet_ptr(x,typ)
 
682
     short typ;
 
683
     object x;
 
684
{  /* doubles are the largest raw type */
 
685
  static double u;
 
686
  if (x==Cnil) return aet_types[typ].dflt;
 
687
  switch (typ){
 
688
#define STORE_TYPED(pl,type,val) *((type *) pl) = (type) val; break;
 
689
  case aet_object: STORE_TYPED(&u,object,x);
 
690
  case aet_ch:     STORE_TYPED(&u,char, char_code(x));
 
691
  case aet_bit:    STORE_TYPED(&u,fixnum, -Mfix(x));
 
692
  case aet_fix:    STORE_TYPED(&u,fixnum, Mfix(x));
 
693
  case aet_sf:     STORE_TYPED(&u,shortfloat, Msf(x));
 
694
  case aet_lf:     STORE_TYPED(&u,longfloat, Mlf(x));
 
695
  case aet_char:   STORE_TYPED(&u, char, Mfix(x));
 
696
  case aet_uchar:  STORE_TYPED(&u, unsigned char, Mfix(x));
 
697
  case aet_short:  STORE_TYPED(&u, short, Mfix(x));
 
698
  case aet_ushort: STORE_TYPED(&u,unsigned short,Mfix(x));
 
699
  default: FEerror("bad elttype",0);
 
700
  }
 
701
  return (char *)&u;
 
702
}
 
703
 
 
704
 
 
705
     /* GSET copies into array ptr P1, the value
 
706
        pointed to by the ptr VAL into the next N slots.  The
 
707
        array type is typ.  If VAL is the null ptr, use
 
708
        the default for that element type
 
709
        NOTE: for type aet_bit n is the number of Words
 
710
        ie (nbits +WSIZE-1)/WSIZE and the words are set.
 
711
        */     
 
712
 
 
713
gset(p1,val,n,typ)
 
714
     char *p1,*val;
 
715
     int n;
 
716
     int typ;
 
717
{ if (val==0)
 
718
    val = aet_types[typ].dflt;
 
719
    switch (typ){
 
720
 
 
721
#define GSET(p,n,typ,val) {typ x = *((typ *) val); GSET1(p,n,typ,x)}
 
722
#define GSET1(p,n,typ,val) while (n-- > 0) \
 
723
      { *((typ *) p) = val; \
 
724
          p = p + sizeof(typ); \
 
725
          } break;
 
726
 
 
727
    case aet_object: GSET(p1,n,object,val);
 
728
    case aet_ch:     GSET(p1,n,char,val);
 
729
      /* Note n is number of fixnum WORDS for bit */
 
730
    case aet_bit:    GSET(p1,n,fixnum,val);
 
731
    case aet_fix:    GSET(p1,n,fixnum,val);
 
732
    case aet_sf:     GSET(p1,n,shortfloat,val);
 
733
    case aet_lf:     GSET(p1,n,longfloat,val);
 
734
    case aet_char:   GSET(p1,n,char,val);
 
735
    case aet_uchar:  GSET(p1,n,unsigned char,val);
 
736
    case aet_short:  GSET(p1,n,short,val);
 
737
    case aet_ushort: GSET(p1,n,unsigned short,val);
 
738
    default:         FEerror("bad elttype",0);
 
739
    }
 
740
  }
 
741
 
 
742
 
 
743
#define W_SIZE (BV_BITS*sizeof(fixnum))    
 
744
 
 
745
  /*
 
746
   */
 
747
 
 
748
DEFUN("COPY-ARRAY-PORTION",object,fScopy_array_portion,SI,4,
 
749
      5,NONE,OO,OI,II,OO,
 
750
   "Copy elements from X to Y starting at x[i1] to x[i2] and doing N1 \
 
751
elements if N1 is supplied otherwise, doing the length of X - I1 \
 
752
elements.  If the types of the arrays are not the same, this has \
 
753
implementation dependent results.")
 
754
     (x,y,i1,i2,n1)
 
755
     object x,y; int i1,i2,n1;
 
756
{ enum aelttype typ1=Iarray_element_type(x);
 
757
  enum aelttype typ2=Iarray_element_type(y);
 
758
  int nc;
 
759
  if (VFUN_NARGS==4)
 
760
    { n1 = x->v.v_dim - i1;}
 
761
  if (typ1==aet_bit)
 
762
    {if (i1 % CHAR_SIZE)
 
763
     badcopy:
 
764
       FEerror("Bit copies only if aligned");
 
765
    else
 
766
      {int rest=n1%CHAR_SIZE;
 
767
       if (rest!=0 )
 
768
         {if (typ2!=aet_bit)
 
769
            goto badcopy;
 
770
            {while(rest> 0)
 
771
               { fSaset1(y,i2+n1-rest,(fSaref1(x,i1+n1-rest)));
 
772
                 rest--;}
 
773
             }}
 
774
       i1=i1/CHAR_SIZE ;
 
775
       n1=n1/CHAR_SIZE;
 
776
       typ1=aet_char;
 
777
     }};
 
778
  if (typ2==aet_bit)
 
779
    {if (i2 % CHAR_SIZE)
 
780
       goto badcopy;
 
781
       i2=i2/CHAR_SIZE ;}
 
782
  if ((typ1 ==aet_object ||
 
783
       typ2  ==aet_object) && typ1 != typ2)
 
784
    FEerror("Can't copy between different array types");
 
785
  nc=n1 * aet_sizes[(int)typ1];
 
786
  if (i1+n1 > x->a.a_dim
 
787
      || ((y->a.a_dim - i2) *aet_sizes[(int)typ2]) < nc)
 
788
    FEerror("Copy  out of bounds");
 
789
  bcopy(x->ust.ust_self + (i1*aet_sizes[(int)typ1]),
 
790
        y->ust.ust_self + (i2*aet_sizes[(int)typ2]),
 
791
        nc);
 
792
  return x;
 
793
}
 
794
 
 
795
/* X is the header of an array.  This supplies the body which
 
796
   will not be relocatable if STATICP.  If DFLT is 0, do not
 
797
   initialize (the caller promises to reset these before the
 
798
   next gc!).   If DFLT == Cnil then initialize to default type
 
799
   for this array type.   Otherwise DFLT is an object and its
 
800
   value is used to init the array */
 
801
   
 
802
array_allocself(x, staticp, dflt)
 
803
object x,dflt;
 
804
int staticp;
 
805
{
 
806
        int i, d,n;
 
807
        char *(*fun)(),*tmp_alloc;
 
808
        enum aelttype typ;
 
809
        fun = (staticp ? alloc_contblock : alloc_relblock);
 
810
        {  /* this must be called from within no interrupt code */
 
811
        n = x->a.a_dim;
 
812
        typ = Iarray_element_type(x);
 
813
        switch (typ) {
 
814
        case aet_object:
 
815
                x->a.a_self = AR_ALLOC(*fun,n,object);
 
816
                break;
 
817
        case aet_ch:
 
818
        case aet_char:
 
819
        case aet_uchar:
 
820
                x->st.st_self = AR_ALLOC(*fun,n,char);
 
821
                break;
 
822
        case aet_short:
 
823
        case aet_ushort:
 
824
                x->ust.ust_self = (unsigned char *) AR_ALLOC(*fun,n,short);
 
825
                break;
 
826
        case aet_bit:
 
827
                n = (n+W_SIZE-1)/W_SIZE;
 
828
                x->bv.bv_offset = 0;
 
829
        case aet_fix:
 
830
                x->fixa.fixa_self = AR_ALLOC(*fun,n,fixnum);
 
831
                break;
 
832
        case aet_sf:
 
833
                x->sfa.sfa_self = AR_ALLOC(*fun,n,shortfloat);
 
834
                break;
 
835
        case aet_lf:
 
836
                x->lfa.lfa_self = AR_ALLOC(*fun,n,longfloat);
 
837
                break;
 
838
        }
 
839
        if(dflt!=0) gset(x->st.st_self,raw_aet_ptr(dflt,typ),n,typ);
 
840
      }
 
841
        
 
842
}
 
843
 
 
844
DEFUNO("FILL-POINTER-SET",int,fSfill_pointer_set,SI,2,2,
 
845
       NONE,IO,IO,OO,OO,siLfill_pointer_set,"")
 
846
     (x,i)
 
847
     object x;
 
848
     int i;
 
849
{
 
850
 
 
851
    if (!(TS_MEMBER(type_of(x),TS(t_vector)|
 
852
                    TS(t_bitvector)|
 
853
                    TS(t_string))))
 
854
      goto no_fillp;
 
855
    if (x->v.v_hasfillp == 0)
 
856
      { goto no_fillp;}
 
857
    if (i < 0 || i > x->a.a_dim)
 
858
      { FEerror("~a is not suitable for a fill pointer for ~a",2,make_fixnum(i),x);}
 
859
    x->v.v_fillp = i;
 
860
    return i;
 
861
  
 
862
  no_fillp:
 
863
        FEerror("~a does not have a fill pointer",1,x);
 
864
 
 
865
  return 0;
 
866
}
 
867
 
 
868
DEFUNO("FILL-POINTER",int,fLfill_pointer,LISP,1,1,NONE,IO,
 
869
       OO,OO,OO,Lfill_pointer,"")
 
870
     (x)
 
871
     object x;
 
872
{
 
873
  if (!(TS_MEMBER(type_of(x),TS(t_vector)|
 
874
                    TS(t_bitvector)|
 
875
                    TS(t_string))))
 
876
    goto no_fillp;
 
877
  if (x->v.v_hasfillp == 0)
 
878
    { goto no_fillp;}
 
879
  return x->v.v_fillp ;
 
880
 
 
881
 no_fillp:
 
882
  FEerror("~a does not have a fill pointer",1,x);
 
883
  return 0;
 
884
} 
 
885
 
 
886
DEFUN("ARRAY-HAS-FILL-POINTER-P",object,
 
887
      fLarray_has_fill_pointer_p,LISP,1,1,NONE,OO,OO,OO,OO,"")
 
888
     (x)
 
889
     object x;
 
890
{
 
891
  if (TS_MEMBER(type_of(x),TS(t_vector)|
 
892
                    TS(t_bitvector)|
 
893
                    TS(t_string)))
 
894
    return (x->v.v_hasfillp == 0 ? Cnil : sLt);
 
895
  else
 
896
    if (TYPE_OF(x) == t_array)
 
897
      { return Cnil;}
 
898
  else IisArray(x);
 
899
  return Cnil;
 
900
}
 
901
 
 
902
 
 
903
        
 
904
/* DEFUN("MAKE-ARRAY-INTERNAL",object,fSmake_array_internal,SI,0,0,NONE,OO,OO,OO,OO)
 
905
 (element_type,adjustable,displaced_to,displaced_index_offset,static,initial_element,dimensions)
 
906
  object element_type,adjustable,displaced_to,displaced_index_offset,static,initial_element,dimensions;
 
907
     
 
908
*/
 
909
 
 
910
DEFUNO("ARRAY-ELEMENT-TYPE",object,fLarray_element_type,
 
911
       LISP,1,1,NONE,OO,OO,OO,OO,Larray_element_type,"")
 
912
     (x)
 
913
     object x;
 
914
{ enum aelttype t;
 
915
  t = Iarray_element_type(x);
 
916
  return * aet_types[(int)t].namep;
 
917
}
 
918
 
 
919
DEFUNO("ADJUSTABLE-ARRAY-P",object,fLadjustable_array_p,
 
920
       LISP,1,1,NONE,OO,OO,OO,OO,Ladjustable_array_p,"")
 
921
     (x)
 
922
     object x;
 
923
{ return sLt;
 
924
}
 
925
 
 
926
DEFUNO("DISPLACED-ARRAY-P",object,fSdisplaced_array_p,SI,1,
 
927
       1,NONE,OO,OO,OO,OO,siLdisplaced_array_p,"")
 
928
     (x)
 
929
     object x;
 
930
{ IisArray(x);
 
931
  return (x->a.a_displaced == Cnil ? Cnil : sLt);
 
932
}
 
933
 
 
934
DEFUNO("ARRAY-RANK",int,fLarray_rank,LISP,1,1,NONE,IO,OO,OO,
 
935
       OO,Larray_rank,"")
 
936
     (x)
 
937
     object x;
 
938
{ if (type_of(x) == t_array)
 
939
    return x->a.a_rank;
 
940
  IisArray(x);
 
941
  return 1;
 
942
}
 
943
 
 
944
DEFUNO("ARRAY-DIMENSION",int,fLarray_dimension,LISP,2,2,
 
945
       NONE,IO,IO,OO,OO,Larray_dimension,"")
 
946
     (x,i)
 
947
     object x; int i;
 
948
{ 
 
949
  if (type_of(x) == t_array)
 
950
   {  if (i >= x->a.a_rank) FEerror("Index to large for array-dimension");
 
951
      else { return x->a.a_dims[i];}}
 
952
   IisArray(x);
 
953
   return x->v.v_dim;
 
954
}
 
955
 
 
956
Icheck_displaced(displaced_list,ar,dim)
 
957
     object displaced_list,ar;
 
958
     int dim;
 
959
{ 
 
960
  while (displaced_list!=Cnil)
 
961
    { object u = Mcar(displaced_list);
 
962
      if (u->a.a_self == NULL) continue;
 
963
      if ((Iarray_element_type(u) == aet_bit &&
 
964
           (u->bv.bv_self - ar->bv.bv_self)*BV_BITS +u->bv.bv_dim -dim
 
965
            + u->bv.bv_offset - ar->bv.bv_offset > 0)
 
966
          || (ARRAY_BODY_PTR(u,u->a.a_dim) > ARRAY_BODY_PTR(ar,dim)))
 
967
        FEerror("Bad displacement",0);
 
968
      Icheck_displaced(DISPLACED_FROM(u),ar,dim);
 
969
      displaced_list = Mcdr(displaced_list);
 
970
    }
 
971
}
 
972
 
 
973
/*
 
974
 (setq a (make-array 2 :displaced-to (setq b (make-array 4 ))))
 
975
        {  A->displ = (B), B->displ=(nil A)}
 
976
(setq w (make-array 3))   ;; w->displaced= (nil y u) 
 
977
(setq y (make-array 2 :displaced-to  w))  ;; y->displaced=(w z z2)
 
978
(setq u (make-array 2 :displaced-to w))   ;; u->displaced = (w)
 
979
(setq z (make-array 2 :displaced-to y))   ;; z->displaced = (y)
 
980
(setq z2 (make-array 2 :displaced-to y))  ;; z2->displaced= (y)
 
981
 
 
982
 
 
983
  Destroy the displacement from AR
 
984
  
 
985
  */
 
986
Iundisplace(ar)
 
987
object ar;
 
988
{ object *p,x; 
 
989
  
 
990
  if ((x = DISPLACED_TO(ar)) == Cnil ||
 
991
      ar->a.a_displaced->d.m == FREE)
 
992
    return;
 
993
  {BEGIN_NO_INTERRUPT;
 
994
   DISPLACED_TO(ar) = Cnil;
 
995
   p = &(DISPLACED_FROM(x)) ;
 
996
   /* walk through the displaced from list and delete AR */
 
997
   while(1)
 
998
     { if ((*p)->d.m == FREE
 
999
           || *p == Cnil)
 
1000
        goto retur;
 
1001
         if((Mcar(*p) == ar))
 
1002
         { *p = Mcdr(*p);
 
1003
           goto retur;}
 
1004
         p = &(Mcdr(*p));
 
1005
       }
 
1006
 retur:
 
1007
   END_NO_INTERRUPT;
 
1008
   return;
 
1009
 }
 
1010
}
 
1011
 
 
1012
DEFUNO("REPLACE-ARRAY",object,fSreplace_array,SI,2,2,NONE,
 
1013
       OO,OO,OO,OO,siLreplace_array,"")
 
1014
 (old,new)
 
1015
     object old,new;
 
1016
{ struct dummy fw ;
 
1017
  fw = old->d;
 
1018
 
 
1019
  old = IisArray(old);
 
1020
  
 
1021
  if (TYPE_OF(old) != TYPE_OF(new)
 
1022
      || (TYPE_OF(old) == t_array && old->a.a_rank != new->a.a_rank))
 
1023
    { FAIL:
 
1024
        FEerror("Cannot do array replacement ~a by ~a",2,old,new);
 
1025
      }
 
1026
  { int offset = new->ust.ust_self  - old->ust.ust_self;
 
1027
    object old_list = DISPLACED_FROM(old);
 
1028
    object displaced = make_cons(DISPLACED_TO(new),DISPLACED_FROM(old));
 
1029
    Icheck_displaced(DISPLACED_FROM(old),old,new->a.a_dim);
 
1030
    adjust_displaced(old,offset);
 
1031
/*    Iundisplace(old); */
 
1032
    if (old->v.v_hasfillp)
 
1033
      { new->v.v_hasfillp = 1;
 
1034
        new->v.v_fillp = old->v.v_fillp;}
 
1035
    if (TYPE_OF(old) == t_string)
 
1036
      old->st = new->st;
 
1037
    else
 
1038
      old->a = new ->a;
 
1039
    
 
1040
    /* prevent having two arrays with the same body--which are not related
 
1041
       that would cause the gc to try to copy both arrays and there might
 
1042
       not be enough space. */
 
1043
    new->a.a_dim = 0;
 
1044
    new->a.a_self = 0;
 
1045
    old->d = fw;
 
1046
    old->a.a_displaced = displaced;
 
1047
  }
 
1048
  return old;
 
1049
}
 
1050
 
 
1051
DEFUNO("ARRAY-TOTAL-SIZE",int,fLarray_total_size,LISP,1,1,
 
1052
       NONE,IO,OO,OO,OO,Larray_total_size,"")
 
1053
     (x)
 
1054
     object x;
 
1055
{ x = IisArray(x);
 
1056
  return x->a.a_dim;
 
1057
}
 
1058
 
 
1059
 
 
1060
DEFUNO("ASET-BY-CURSOR",object,fSaset_by_cursor,SI,3,3,
 
1061
       NONE,OO,OO,OO,OO,siLaset_by_cursor,"")(array,val,cursor)
 
1062
object array,val,cursor;
 
1063
{
 
1064
        object endp_temp;
 
1065
        object x;
 
1066
        int i;
 
1067
        object ind[ARRAY_RANK_LIMIT];
 
1068
        /* 3 args */
 
1069
        ind[0]=array;
 
1070
        if (cursor==sLnil) {fSaset1(array,0,val); RETURN1(array);}
 
1071
        ind[1]=MMcar(cursor);
 
1072
        i = 2;
 
1073
        for (x = MMcdr(cursor);  !endp(x);  x = MMcdr(x))
 
1074
          { ind[i++] = MMcar(x);}
 
1075
        ind[i]=val;
 
1076
        VFUN_NARGS=i+1;
 
1077
        c_apply_n(fSaset,i+1,ind);
 
1078
        RETURN1(array);
 
1079
}
 
1080
 
 
1081
init_array_function(){;}
 
1082
     
 
1083
 
 
1084
 
 
1085