home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / array.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  25.5 KB  |  1,126 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.     array.c
  24.  
  25.     array routines
  26. */
  27.  
  28. #include "include.h"
  29.  
  30. #define    ADIMLIM        16*1024*1024
  31. #define    ATOTLIM        16*1024*1024
  32. #define WSIZE  CHAR_SIZE*sizeof(fixnum)
  33.  
  34. enum aelttype
  35. get_aelttype(x)
  36. object x;
  37. {
  38.     if (x == Sstring_char)
  39.         return(aet_ch);
  40.     else if (x == Sbit)
  41.         return(aet_bit);
  42.     else if (x == Sfixnum)
  43.         return(aet_fix);
  44.     else if (x == Sshort_float)
  45.         return(aet_sf);
  46.     else if (x == Slong_float || x == Ssingle_float || x==Sdouble_float)
  47.         return(aet_lf);
  48.     else if (x == Sunsigned_char)
  49.       return(aet_uchar);
  50.     else if (x == Sunsigned_short)
  51.       return(aet_ushort);
  52.     else if (x == Ssigned_char)
  53.       return(aet_char);
  54.     else if (x == Ssigned_short)
  55.       return(aet_short);
  56.     else
  57.         return(aet_object);
  58. }
  59.  
  60. enum aelttype
  61. array_elttype(x)
  62. object x;
  63. {
  64.     switch(type_of(x)) {
  65.     case t_array:
  66.     case t_vector:
  67.         return((enum aelttype)x->a.a_elttype);
  68.  
  69.     case t_string:
  70.         return(aet_ch);
  71.  
  72.     case t_bitvector:
  73.         return(aet_bit);
  74.  
  75.     default:
  76.         FEwrong_type_argument(Sarray, x);
  77.     }
  78. }
  79.  
  80. char *
  81. array_address(x, inc)
  82. object x;
  83. int inc;
  84. {
  85.     switch(array_elttype(x)) {
  86.     case aet_object:
  87.     case aet_fix:
  88.     case aet_sf:
  89.         return((char *)(x->a.a_self + inc));
  90.  
  91.         case aet_char:
  92.         case aet_uchar:
  93.     case aet_ch:
  94.         return(x->st.st_self + inc);
  95.  
  96.         case aet_short:
  97.         case aet_ushort:
  98.         return ((char *)&(USHORT(x,inc)));
  99.  
  100.     case aet_lf:
  101.         return((char *)(x->lfa.lfa_self + inc));
  102.           default:
  103.         FEerror("Bad array type",0);
  104.     }
  105. }
  106.  
  107. static object DFLT_aet_object = Cnil;    
  108. static char DFLT_aet_ch = ' ';
  109. static char DFLT_aet_char = 0; 
  110. static int DFLT_aet_fix = 0  ;        
  111. static short DFLT_aet_short = 0;
  112. static shortfloat DFLT_aet_sf = 0.0;
  113. static longfloat DFLT_aet_lf = 0.0;    
  114.  
  115. char * default_aet_types[] =
  116. {   (char *)    &DFLT_aet_object,        /*  t  */
  117.     (char *)    &DFLT_aet_ch,            /*  string-char  */
  118.     (char *)    &DFLT_aet_fix,        /*  bit  */
  119.     (char *)    &DFLT_aet_fix,        /*  fixnum  */
  120.     (char *)    &DFLT_aet_sf,            /*  short-float  */
  121.     (char *)    &DFLT_aet_lf,            /*  long-float  */
  122.     (char *)    &DFLT_aet_char,               /* signed char */
  123.     (char *)    &DFLT_aet_char,               /* unsigned char */
  124.     (char *)    &DFLT_aet_short,              /* signed short */
  125.     (char *)    &DFLT_aet_short,             /*  unsigned short   */
  126.     };
  127.  
  128.    /* RAW_AET_PTR returns a pointer to something of raw type obtained from X
  129.       suitable for using GSET for an array of elt type TYP.
  130.       If x is the null pointer, return a default for that array element
  131.       type.
  132.       */
  133.  
  134. char *
  135. raw_aet_ptr(x,typ)
  136.      short typ;
  137.      object x;
  138. {  /* doubles are the largest raw type */
  139.   static double u;
  140.   if (x==Cnil) return default_aet_types[typ];
  141.   switch (typ){
  142. #define STORE_TYPED(pl,type,val) *((type *) pl) = (type) val; break;
  143.   case aet_object: STORE_TYPED(&u,object,x);
  144.   case aet_ch:     STORE_TYPED(&u,char, char_code(x));
  145.   case aet_bit:    STORE_TYPED(&u,fixnum, -fix(x));
  146.   case aet_fix:    STORE_TYPED(&u,fixnum, fix(x));
  147.   case aet_sf:     STORE_TYPED(&u,shortfloat, sf(x));
  148.   case aet_lf:     STORE_TYPED(&u,longfloat, lf(x));
  149.   case aet_char:   STORE_TYPED(&u, char, fix(x));
  150.   case aet_uchar:  STORE_TYPED(&u, unsigned char, fix(x));
  151.   case aet_short:  STORE_TYPED(&u, short, fix(x));
  152.   case aet_ushort: STORE_TYPED(&u,unsigned short,fix(x));
  153.   default: FEerror("bad elttype",0);
  154.   }
  155.   return (char *)&u;
  156. }
  157.  
  158.  
  159.      /* GSET copies into array ptr P1, the value
  160.     pointed to by the ptr VAL into the next N slots.  The
  161.     array type is typ.  If VAL is the null ptr, use
  162.     the default for that element type
  163.     NOTE: for type aet_bit n is the number of Words
  164.     ie (nbits +WSIZE-1)/WSIZE and the words are set.
  165.     */     
  166.  
  167. gset(p1,val,n,typ)
  168.      char *p1,*val;
  169.      int n;
  170.      int typ;
  171. { if (val==0)
  172.     val = default_aet_types[typ];
  173.     switch (typ){
  174.  
  175. #define GSET(p,n,typ,val) {typ x = *((typ *) val); GSET1(p,n,typ,x)}
  176. #define GSET1(p,n,typ,val) while (n-- > 0) \
  177.       { *((typ *) p) = val; \
  178.       p = p + sizeof(typ); \
  179.       } break;
  180.  
  181.     case aet_object: GSET(p1,n,object,val);
  182.     case aet_ch:     GSET(p1,n,char,val);
  183.       /* Note n is number of fixnum WORDS for bit */
  184.     case aet_bit:    GSET(p1,n,fixnum,val);
  185.     case aet_fix:    GSET(p1,n,fixnum,val);
  186.     case aet_sf:     GSET(p1,n,shortfloat,val);
  187.     case aet_lf:     GSET(p1,n,longfloat,val);
  188.     case aet_char:   GSET(p1,n,char,val);
  189.     case aet_uchar:  GSET(p1,n,unsigned char,val);
  190.     case aet_short:  GSET(p1,n,short,val);
  191.     case aet_ushort: GSET(p1,n,unsigned short,val);
  192.     default:         FEerror("bad elttype",0);
  193.     }
  194.   }
  195.  
  196. #ifndef COM_LENG
  197. #define COM_LENG
  198. #endif
  199. extern short aet_sizes[COM_LENG];
  200. #define W_SIZE (CHAR_SIZE*sizeof(fixnum))    
  201. /*  This copies from p1 to p2 n elements of typ 
  202. gcopy(p1,p2,n,typ)
  203. char *p1,*p2;
  204. int n,typ;
  205. { if(typ== (int)aet_bit)
  206.  
  207.     bcopy(p1,p2,(n+CHAR_SIZE-1)/CHAR_SIZE);
  208.   else
  209.     bcopy(p1,p2,n*aet_sizes[(int) typ]);
  210. }
  211. */
  212.   /* Copy n1 elements from x to y starting at x[i1]  to x[i2]
  213.      If the types of the arrays are not the same, this has
  214.      implementation dependent results.
  215.    */
  216.    
  217.      
  218. copy_array_portion(x,y,i1,i2,n1)
  219.      object x,y; int i1,i2,n1;
  220. { enum aelttype typ1=array_elttype(vs_base[0]);
  221.   enum aelttype typ2=array_elttype(vs_base[1]);
  222.   int nc;
  223.   if (typ1==aet_bit)
  224.     {if (i1 % CHAR_SIZE)
  225.      badcopy:
  226.        FEerror("Bit copies only if aligned");
  227.      else
  228.        {int rest=n1%CHAR_SIZE;
  229.     if (rest!=0 )
  230.       {if (typ2!=aet_bit)
  231.          goto badcopy;
  232.        {while(rest> 0)
  233.          { aset1(y,i2+n1-rest,(aref1(x,i1+n1-rest)));
  234.            rest--;}
  235.       }}
  236.     i1=i1/CHAR_SIZE ;
  237.     n1=n1/CHAR_SIZE;
  238.     typ1=aet_char;
  239.      }};
  240.   if (typ2==aet_bit)
  241.     {if (i2 % CHAR_SIZE)
  242.        goto badcopy;
  243.        i2=i2/CHAR_SIZE ;}
  244.   if ((typ1 ==aet_object ||
  245.        typ2  ==aet_object) && typ1 != typ2)
  246.     FEerror("Can't copy between different array types");
  247.   nc=n1 * aet_sizes[(int)typ1];
  248.   if (i1+n1 > x->a.a_dim
  249.       || ((y->a.a_dim - i2) *aet_sizes[(int)typ2]) < nc)
  250.     FEerror("Copy  out of bounds");
  251.   bcopy(x->ust.ust_self + (i1*aet_sizes[(int)typ1]),
  252.     y->ust.ust_self + (i2*aet_sizes[(int)typ2]),
  253.     nc);
  254. }
  255.  
  256. /* Copy from X to Y starting at indices i1 and i2 and
  257.    going optional N places (or array-total-size(x) -i1)
  258.    if not specified
  259.  */
  260.  
  261. siLcopy_array_portion()
  262. {int n;
  263.  if (vs_top-vs_base == 5)
  264.    {n=fix(vs_base[4]);}
  265.  else
  266.    {check_arg(4);
  267.     if(type_of(vs_base[3]) !=t_fixnum ||
  268.      type_of(vs_base[2]) !=t_fixnum )
  269.       FEerror("Need fixnum index");
  270.     n= vs_base[0]->a.a_dim - fix(vs_base[2]);
  271.   }
  272.  copy_array_portion(vs_base[0],vs_base[1],fix(vs_base[2]),
  273.             fix(vs_base[3]),n);
  274.   vs_top=vs_base+1;
  275. }
  276.  
  277.  
  278.  
  279. /* X is the header of an array.  This supplies the body which
  280.    will not be relocatable if STATICP.  If DFLT is 0, do not
  281.    initialize (the caller promises to reset these before the
  282.    next gc!).   If DFLT == Cnil then initialize to default type
  283.    for this array type.   Otherwise DFLT is an object and its
  284.    value is used to init the array */
  285.    
  286. array_allocself(x, staticp,dflt)
  287. object x,dflt;
  288. bool staticp;
  289. {
  290.     int i, d;
  291.     char *(*f)(),*tmp_alloc;
  292.     enum aelttype typ;
  293.  
  294.     d = x->a.a_dim;
  295.     if (staticp)
  296.         f = alloc_contblock;
  297.     else
  298.         f = alloc_relblock;
  299.     typ=array_elttype(x);
  300.     switch (typ) {
  301.     case aet_object:
  302.         x->a.a_self = AR_ALLOC(*f,d,object);
  303.         break;
  304.     case aet_ch:
  305.     case aet_char:
  306.         case aet_uchar:
  307.         x->st.st_self = AR_ALLOC(*f,d,char);
  308.         break;
  309.         case aet_short:
  310.         case aet_ushort:
  311.         x->ust.ust_self = (unsigned char *) AR_ALLOC(*f,d,short);
  312.         break;
  313.     case aet_bit:
  314.         d = (d+W_SIZE-1)/W_SIZE;
  315.         x->bv.bv_offset = 0;
  316.     case aet_fix:
  317.         x->fixa.fixa_self = AR_ALLOC(*f,d,fixnum);
  318.         break;
  319.     case aet_sf:
  320.         x->sfa.sfa_self = AR_ALLOC(*f,d,shortfloat);
  321.         break;
  322.     case aet_lf:
  323.         x->lfa.lfa_self = AR_ALLOC(*f,d,longfloat);
  324.         break;
  325.     }
  326.     if(dflt!=0) gset(x->st.st_self,raw_aet_ptr(dflt,typ),d,typ);
  327. }
  328.  
  329. object
  330. aref(x, index)
  331. object x;
  332. int index;
  333. {
  334.     if (index >= x->a.a_dim) {
  335.         vs_push(make_fixnum(index));
  336.         FEerror("The index, ~D, is too large.", 1, vs_head);
  337.     }
  338.     switch (array_elttype(x)) {
  339.     case aet_object:
  340.         return(x->a.a_self[index]);
  341.  
  342.     case aet_ch:
  343.         return(code_char(x->ust.ust_self[index]));
  344.  
  345.     case aet_bit:
  346.         index += x->bv.bv_offset;
  347.         if (x->bv.bv_self[index/8] & (0200>>index%8))
  348.             return(small_fixnum(1));
  349.         else
  350.             return(small_fixnum(0));
  351.  
  352.     case aet_fix:
  353.         return(make_fixnum(x->fixa.fixa_self[index]));
  354.  
  355.  
  356. #define UCHAR(x,index) ((x)->ust.ust_self[index])
  357.  
  358.     case aet_uchar:
  359.         return(make_fixnum((fixnum)(UCHAR(x,index))));
  360.   
  361.     case aet_char:
  362.         return(make_fixnum((fixnum)(SIGNED_CHAR(UCHAR(x,index)))));
  363.         
  364.         case aet_short:
  365.       return(make_fixnum((fixnum)(short)USHORT(x,index)));
  366.  
  367.         case aet_ushort:
  368.       return(make_fixnum((fixnum)USHORT(x,index)));
  369.  
  370.     case aet_sf:
  371.         return(make_shortfloat(x->sfa.sfa_self[index]));
  372.  
  373.     case aet_lf:
  374.         return(make_longfloat(x->lfa.lfa_self[index]));
  375.     }
  376. }
  377.  
  378. object
  379. aset(x, index, value)
  380. object x;
  381. int index;
  382. object value;
  383. {
  384.     int i;
  385.  
  386.     if (index >= x->a.a_dim) {
  387.         vs_push(make_fixnum(index));
  388.         FEerror("The index, ~D, too large.", 1, vs_head);
  389.     }
  390.     switch (array_elttype(x)) {
  391.     case aet_object:
  392.         x->a.a_self[index] = value;
  393.         break;
  394.  
  395.     case aet_ch:
  396.         if (type_of(value) != t_character)
  397.             FEerror("~S is not a character.", 1, value);
  398.         x->st.st_self[index] = value->ch.ch_code;
  399.         break;
  400.  
  401.     case aet_bit:
  402.         i = fixint(value);
  403.         if (i != 0 && i != 1)
  404.             FEerror("~S is not a bit.", 1, value);
  405.         index += x->bv.bv_offset;
  406.         if (i == 0)
  407.             x->bv.bv_self[index/8] &= ~(0200>>index%8);
  408.         else
  409.             x->bv.bv_self[index/8] |= 0200>>index%8;
  410.         break;
  411.  
  412.     case aet_fix:
  413.         x->fixa.fixa_self[index] = fixint(value);
  414.         break;
  415.         
  416.     case aet_char:
  417.         case aet_uchar:
  418.         x->ust.ust_self[index]=(unsigned char)fixint(value);
  419.         break;
  420.  
  421.     case aet_short:
  422.         case aet_ushort:
  423.         USHORT(x,index) = (unsigned short)fixint(value);
  424.         break;
  425.  
  426.     case aet_sf:
  427.         x->sfa.sfa_self[index] = object_to_double(value);
  428.         break;
  429.  
  430.     case aet_lf:
  431.         x->lfa.lfa_self[index] = object_to_double(value);
  432.         break;
  433.     }
  434.     return(value);
  435. }
  436.  
  437. object
  438. aref1(v, index)
  439. object v;
  440. int index;
  441. {
  442.     int i;
  443.     object l;
  444.  
  445.     if (index < 0) {
  446.         vs_push(make_fixnum(index));
  447.         FEerror("Negative index: ~D.", 1, vs_head);
  448.     }
  449.     switch (type_of(v)) {
  450.     case t_vector:
  451.     case t_bitvector:
  452.         return(aref(v, index));
  453.  
  454.     case t_string:
  455.         if (index >= v->st.st_dim)
  456.             goto E;
  457.         return(code_char(v->ust.ust_self[index]));
  458.  
  459.     default:
  460.         FEerror("~S is not a vector.", 1, v);
  461.     }
  462.  
  463. E:
  464.     vs_push(make_fixnum(index));
  465.     FEerror("The index, ~D, is too large.", 1, vs_head);
  466. }
  467.  
  468. object
  469. aset1(v, index, val)
  470. object v;
  471. int index;
  472. object val;
  473. {
  474.     int i;
  475.     object l;
  476.  
  477.     if (index < 0) {
  478.         vs_push(make_fixnum(index));
  479.         FEerror("Negative index: ~D.", 1, vs_head);
  480.     }
  481.     switch (type_of(v)) {
  482.     case t_vector:
  483.     case t_bitvector:
  484.         return(aset(v, index, val));
  485.  
  486.     case t_string:
  487.         if (index >= v->st.st_dim)
  488.             goto E;
  489.         if (type_of(val) != t_character)
  490.             FEerror("~S is not a character.", 1, val);
  491.         v->st.st_self[index] = val->ch.ch_code;
  492.         return(val);
  493.  
  494.     default:
  495.         FEerror("~S is not a vector.", 1, v);
  496.     }
  497.  
  498. E:
  499.     vs_push(make_fixnum(index));
  500.     FEerror("The index, ~D, is too large", 1, vs_head);
  501. }
  502.  
  503. /*
  504.     Displace(from, to, offset) displaces the from-array
  505.     to the to-array (the original array) by the specified offset.
  506.     It changes the a_displaced field of both arrays.
  507.     The field is a cons; the car of the from-array points to
  508.     the to-array and the cdr of the to-array is a list of arrays
  509.     displaced to the to-array, so the from-array is pushed to the
  510.     cdr of the to-array's a_displaced.
  511. */
  512. displace(from, to, offset)
  513. object from, to, offset;
  514. {
  515.     int j;
  516.     enum aelttype totype, fromtype;
  517.  
  518.     j = fixnnint(offset);
  519.     totype = array_elttype(to);
  520.     fromtype = array_elttype(from);
  521.     if (totype != fromtype)
  522.         FEerror("Cannot displace the array,~%\
  523. because the element types don't match.", 0);
  524.     if (j + from->a.a_dim > to->a.a_dim)
  525.         FEerror("Cannot displace the array,~%\
  526. because the total size of the to-array is too small.", 0);
  527.     from->a.a_displaced = make_cons(to, Cnil);
  528.     if (to->a.a_displaced == Cnil)
  529.         to->a.a_displaced = make_cons(Cnil, Cnil);
  530.     to->a.a_displaced->c.c_cdr =
  531.     make_cons(from, to->a.a_displaced->c.c_cdr);
  532.     if (fromtype == aet_bit) {
  533.         j += to->bv.bv_offset;
  534.         from->bv.bv_self = to->bv.bv_self + j/8;
  535.         from->bv.bv_offset = j%8;
  536.     }
  537. #ifdef MV
  538.  
  539.  
  540. #endif
  541.     else
  542.         from->st.st_self = array_address(to, j);
  543. }
  544.  
  545. /*  (setq a (make-array 2 :displaced-to (setq b (make-array 4 )))) {  A->displ = (B), B->displ=(nil A)}
  546.     Undisplace(from) destroys the displacement from the from-array.
  547. */
  548. undisplace(from)
  549. object from;
  550. {
  551.     object *p;
  552.     object to;
  553.     
  554.       /* if the cons is free, neither the FROM nor the TO array will
  555.          survive the gc (or we would have marked this), and we can
  556.          skip undisplacing */
  557.     
  558.     if (from->a.a_displaced->d.m == FREE) return;
  559.     to= from->a.a_displaced->c.c_car;
  560.     
  561.     if (to == Cnil)
  562.         return;
  563.     from->a.a_displaced->c.c_car = Cnil;
  564.     for (p = &(to->a.a_displaced->c.c_cdr);;  p = &((*p)->c.c_cdr)){
  565.  
  566.       if ((*p)->d.m == FREE) return;
  567.       /* During the sweep phase we sometimes null out the rest of this list
  568.          if the array is being displaced.
  569.          */
  570.       if (*p == Cnil) return; 
  571.       if ((*p)->c.c_car == from) {
  572.         *p = (*p)->c.c_cdr;
  573.         return;
  574.         }}
  575. }
  576.  
  577. /*
  578.     Check_displaced(dlist, orig, newdim) checks if the displaced
  579.     arrays can keep the displacement when the original array is
  580.     adjusted.
  581.     Dlist is the list of displaced arrays, orig is the original array
  582.     and newdim is the new dimension of the original array.
  583. */
  584. check_displaced(dlist, orig, newdim)
  585. object dlist, orig;
  586. int newdim;
  587. {
  588.     object x;
  589.  
  590.     for (;  dlist != Cnil;  dlist = dlist->c.c_cdr) {
  591.         x = dlist->c.c_car;
  592.         if (x->a.a_self == NULL)
  593.             continue;
  594.         if (array_elttype(x) != aet_bit) {
  595.             if (array_address(x, x->a.a_dim) >
  596.                 array_address(orig, newdim))
  597.                 FEerror("Can't keep displacement.", 0);
  598.         } else {
  599.             if ((x->bv.bv_self - orig->bv.bv_self)*8 +
  600.                 x->bv.bv_dim - newdim +
  601.                 x->bv.bv_offset - orig->bv.bv_offset > 0)
  602.                 FEerror("Can't keep displacement.", 0);
  603.         }
  604.         check_displaced(x->a.a_displaced->c.c_cdr, orig, newdim);
  605.     }
  606. }
  607.  
  608. /*
  609.     Adjust_displaced(x, diff) adds the int value diff
  610.     to the a_self field of the array x and all the arrays displaced to x.
  611.     This function is used in siLreplace_array (ADJUST-ARRAY) and
  612.     the garbage collector.
  613. */
  614. adjust_displaced(x, diff)
  615. object x;
  616. int diff;
  617. {
  618.     if (x->a.a_self != NULL)
  619.         x->a.a_self = (object *)((int)(x->a.a_self) + diff);
  620.     for (x = x->a.a_displaced->c.c_cdr;  x != Cnil;  x = x->c.c_cdr)
  621.         adjust_displaced(x->c.c_car, diff);
  622. }
  623.  
  624. setup_fillp(x, fillp)
  625. object x, fillp;
  626. {
  627.     int j;
  628.  
  629.     if (fillp == Cnil) {
  630.         x->v.v_hasfillp = FALSE;
  631.         x->v.v_fillp = x->v.v_dim;
  632.     } else if (fillp == Ct) {
  633.         x->v.v_hasfillp = TRUE;
  634.         x->v.v_fillp = x->v.v_dim;
  635.     } else if ((j = fixnnint(fillp)) > x->v.v_dim)
  636.         FEerror("The fill-pointer ~S is too large.", 1, fillp);
  637.     else {
  638.         x->v.v_hasfillp = TRUE;
  639.         x->v.v_fillp = j;
  640.     }
  641. }
  642.  
  643. /*
  644.     Internal function for making arrays:
  645.  
  646.         (si:make-pure-array element-type adjustable
  647.                         displaced-to displaced-index-offset
  648.                     static initial-element
  649.                         dim0 dim1 ... )
  650. */
  651. siLmake_pure_array()
  652. {
  653.     int r, s, i, j;
  654.     object x;
  655.  
  656.     r = vs_top - vs_base - 6;
  657.     if (r < 0)
  658.         too_few_arguments();
  659.     x = alloc_object(t_array);
  660.     x->a.a_self = NULL;
  661.     x->a.a_displaced = Cnil;
  662.     x->a.a_rank = r;
  663.     x->a.a_dims = NULL;
  664.     x->a.a_elttype = (short)get_aelttype(vs_base[0]);
  665.     vs_base[0] = x;
  666.     x->a.a_dims = AR_ALLOC(alloc_relblock,r,int);
  667.     if (r >= ARANKLIM) {
  668.         vs_push(make_fixnum(r));
  669.         FEerror("The array rank, ~R, is too large.", 1, vs_head);
  670.     }
  671.     for (i = 0, s = 1;  i < r;  i++) {
  672.         if ((j = fixnnint(vs_base[i+6])) > ADIMLIM) {
  673.             vs_push(make_fixnum(i+1));
  674.             FEerror("The ~:R array dimension, ~D, is too large.",
  675.                 2, vs_head, vs_base[i+6]);
  676.         }
  677.         s *= (x->a.a_dims[i] = j);
  678.     }
  679.     if (s > ATOTLIM) {
  680.         vs_push(make_fixnum(s));
  681.         FEerror("The array total size, ~D, is too large.",
  682.             1, vs_head);
  683.     }
  684.     x->a.a_dim = s;
  685.     x->a.a_adjustable = vs_base[1] != Cnil;
  686.     if (vs_base[2] == Cnil)
  687.         array_allocself(x, vs_base[4] != Cnil,vs_base[5]);
  688.     else
  689.         displace(x, vs_base[2], vs_base[3]);
  690.     vs_top = vs_base + 1;
  691. }
  692.  
  693. /*
  694.     Internal function for making vectors:
  695.  
  696.         (si:make-vector element-type dimension adjustable fill-pointer
  697.                 displaced-to displaced-index-offset
  698.                     static &optional initial-element)
  699. */
  700. siLmake_vector()
  701. {
  702.     int d, i, j;
  703.     object x;
  704.     object dflt=Cnil;
  705.     enum aelttype aet;
  706.         if (vs_top-vs_base == 8)
  707.       {dflt=vs_base[7];}
  708.     else {check_arg(7);}
  709.     aet = get_aelttype(vs_base[0]);
  710.     if ((d = fixnnint(vs_base[1])) > ADIMLIM)
  711.         FEerror("The vector dimension, ~D, is too large.",
  712.             1, vs_base[1]);
  713.     if (aet == aet_ch)
  714.         x = alloc_object(t_string);
  715.     else if (aet == aet_bit)
  716.         x = alloc_object(t_bitvector);
  717.     else
  718.         x = alloc_object(t_vector);
  719.     x->v.v_self = NULL;
  720.     x->v.v_displaced = Cnil;
  721.     x->v.v_dim = d;
  722.     x->v.v_adjustable = vs_base[2] != Cnil;
  723.     if (aet != aet_ch && aet != aet_bit)
  724.         x->v.v_elttype = (short)aet;
  725.     vs_base[0] = x;
  726.     setup_fillp(x, vs_base[3]);
  727.     if (vs_base[4] == Cnil)
  728.         array_allocself(x, vs_base[6] != Cnil,dflt);
  729.     else
  730.         displace(x, vs_base[4], vs_base[5]);
  731.     vs_top = vs_base + 1;
  732. }
  733.  
  734. Laref()
  735. {
  736.     int r, s, i, j;
  737.     object x;
  738.  
  739.     r = vs_top - vs_base - 1;
  740.     if (r < 0)
  741.         too_few_arguments();
  742.     x = vs_base[0];
  743.     switch (type_of(x)) {
  744.     case t_array:
  745.         if (r != x->a.a_rank)
  746.             FEerror("Wrong number of indices.", 0);
  747.         for (i = j = 0;  i < r;  i++) {
  748.             if ((s = fixnnint(vs_base[i+1])) >= x->a.a_dims[i]) {
  749.                 vs_push(make_fixnum(i+1));
  750.                 FEerror("The ~:R index, ~S, to the array~%\
  751. ~S is too large.", 3, vs_head, vs_base[i+1], x);
  752.             }
  753.             j = j*(x->a.a_dims[i]) + s;
  754.         }
  755.         break;
  756.  
  757.     case t_vector:
  758.     case t_string:
  759.     case t_bitvector:
  760.         if (r != 1)
  761.             FEerror("Wrong number of indices.", 0);
  762.         j = fixnnint(vs_base[1]);
  763.         if (j >= x->v.v_dim) {
  764.             FEerror("The first index, ~S, to the array~%\
  765. ~S is too large.", 2, vs_base[1], x);
  766.         }
  767.         break;
  768.  
  769.     default:
  770.         FEwrong_type_argument(Sarray, x);
  771.     }
  772.     vs_base[0] = aref(x, j);
  773.     vs_top = vs_base + 1;
  774. }
  775.  
  776. /*
  777.     Internal function for setting array elements:
  778.  
  779.         (si:aset array dim0 dim1 ... newvalue)
  780. */
  781. siLaset()
  782. {
  783.     int r, s, i, j;
  784.     object x;
  785.  
  786.     r = vs_top - vs_base - 2;
  787.     if (r < 0)
  788.         too_few_arguments();
  789.     x = vs_base[0];
  790.     switch (type_of(x)) {
  791.     case t_array:
  792.         if (r != x->a.a_rank)
  793.             FEerror("Wrong number of indices.", 0);
  794.         for (i = j = 0;  i < r;  i++) {
  795.             if ((s = fixnnint(vs_base[i+1])) >= x->a.a_dims[i]) {
  796.                 vs_push(make_fixnum(i+1));
  797.                 FEerror("The ~:R index, ~S, to the array~%\
  798. ~S is too large.", 3, vs_head, vs_base[i+1], x);
  799.             }
  800.             j = j*(x->a.a_dims[i]) + s;
  801.         }
  802.         break;
  803.  
  804.     case t_vector:
  805.     case t_string:
  806.     case t_bitvector:
  807.         if (r != 1)
  808.             FEerror("Wrong number of indices.", 0);
  809.         j = fixnnint(vs_base[1]);
  810.         if (j >= x->v.v_dim) {
  811.             FEerror("The first index, ~S, to the array~%\
  812. ~S is too large.", 2, vs_base[1], x);
  813.         }
  814.         break;
  815.  
  816.     default:
  817.         FEwrong_type_argument(Sarray, x);
  818.     }
  819.     aset(x, j, vs_base[r+1]);
  820.     vs_base[0] = vs_base[r+1];
  821.     vs_top = vs_base + 1;
  822. }
  823.  
  824. Larray_element_type()
  825. {
  826.     check_arg(1);
  827.  
  828.     switch (array_elttype(vs_base[0])) {
  829.     case aet_object:
  830.         vs_base[0] = Ct;
  831.         break;
  832.  
  833.     case aet_ch:
  834.         vs_base[0] = Sstring_char;
  835.         break;
  836.  
  837.     case aet_bit:
  838.         vs_base[0] = Sbit;
  839.         break;
  840.  
  841.     case aet_fix:
  842.         vs_base[0] = Sfixnum;
  843.         break;
  844.  
  845.         case aet_char:
  846.         vs_base[0]= Ssigned_char;
  847.         break;
  848.  
  849.         case aet_uchar:
  850.         vs_base[0]= Sunsigned_char;
  851.         break;
  852.         case aet_short:
  853.         vs_base[0]= Ssigned_short;
  854.         break;
  855.         case aet_ushort:
  856.         vs_base[0]= Sunsigned_short;
  857.         break;
  858.     case aet_sf:
  859.         vs_base[0] = Sshort_float;
  860.         break;
  861.  
  862.     case aet_lf:
  863.         vs_base[0] = Slong_float;
  864.         break;
  865.     }
  866. }
  867.  
  868. Larray_rank()
  869. {
  870.     check_arg(1);
  871.     check_type_array(&vs_base[0]);
  872.     if (type_of(vs_base[0]) == t_array)
  873.         vs_base[0] = make_fixnum(vs_base[0]->a.a_rank);
  874.     else
  875.         vs_base[0] = make_fixnum(1);
  876. }
  877.  
  878. Larray_dimension()
  879. {
  880.     int i;
  881.  
  882.     check_arg(2);
  883.     check_type_array(&vs_base[0]);
  884.     i = fixnnint(vs_base[1]);
  885.     if (type_of(vs_base[0]) == t_array) {
  886.         if (i >= vs_base[0]->a.a_rank)
  887.             goto ILLEGAL;
  888.         vs_base[0] = make_fixnum(vs_base[0]->a.a_dims[i]);
  889.     } else {
  890.         if (i != 0)
  891.             goto ILLEGAL;
  892.         vs_base[0] = make_fixnum(vs_base[0]->v.v_dim);
  893.     }
  894.     vs_top = vs_base + 1;
  895.     return;
  896.  
  897. ILLEGAL:
  898.     FEerror("~S is an illegal axis-number to the array~%\
  899. ~S.", 2, vs_base[1], vs_base[0]);
  900.  
  901. }
  902.  
  903. Larray_total_size()
  904. {
  905.     check_arg(1);
  906.     check_type_array(&vs_base[0]);
  907.     vs_base[0] = make_fixnum(vs_base[0]->a.a_dim);
  908. }
  909.  
  910. Ladjustable_array_p()
  911. {
  912.     check_arg(1);
  913.     check_type_array(&vs_base[0]);
  914.     if (vs_base[0]->a.a_adjustable)
  915.         vs_base[0] = Ct;
  916.     else
  917.         vs_base[0] = Cnil;
  918. }
  919.  
  920. /*
  921.     Internal function for checking if an array is displaced.
  922. */
  923. siLdisplaced_array_p()
  924. {
  925.     check_arg(1);
  926.     check_type_array(&vs_base[0]);
  927.     if (vs_base[0]->a.a_displaced->c.c_car != Cnil)
  928.         vs_base[0] = Ct;
  929.     else
  930.         vs_base[0] = Cnil;
  931. }
  932.  
  933. Lsvref()
  934. {
  935.     int i;
  936.     object x;
  937.  
  938.     check_arg(2);
  939.     x = vs_base[0];
  940.     if (type_of(x) != t_vector ||
  941.         x->v.v_adjustable ||
  942.         x->v.v_hasfillp ||
  943.         x->v.v_displaced->c.c_car != Cnil ||
  944.         (enum aelttype)x->v.v_elttype != aet_object)
  945.         FEerror("~S is not a simple general vector.", 1, x);
  946.     if ((i = fix(vs_base[1])) >= x->v.v_dim)
  947.         illegal_index(x, vs_base[1]);
  948.     vs_base[0] = x->v.v_self[i];
  949.     vs_pop;
  950. }
  951.  
  952. siLsvset()
  953. {
  954.     int i;
  955.     object x;
  956.  
  957.     check_arg(3);
  958.     x = vs_base[0];
  959.     if (type_of(x) != t_vector ||
  960.         x->v.v_adjustable ||
  961.         x->v.v_hasfillp ||
  962.         x->v.v_displaced->c.c_car != Cnil ||
  963.         (enum aelttype)x->v.v_elttype != aet_object)
  964.         FEerror("~S is not a simple general vector.", 1, x);
  965.     if ((i = fixnnint(vs_base[1])) >= x->v.v_dim)
  966.         illegal_index(x, vs_base[1]);
  967.     vs_base[0] = x->v.v_self[i] = vs_base[2];
  968.     vs_pop;
  969.     vs_pop;
  970. }
  971.  
  972. Larray_has_fill_pointer_p()
  973. {
  974.     check_arg(1);
  975.     check_type_array(&vs_base[0]);
  976.     if (type_of(vs_base[0]) == t_array)
  977.         vs_base[0] = Cnil;
  978.     else if (vs_base[0]->v.v_hasfillp)
  979.         vs_base[0] = Ct;
  980.     else
  981.         vs_base[0] = Cnil;
  982. }
  983.  
  984. Lfill_pointer()
  985. {
  986.     check_arg(1);
  987.     check_type_vector(&vs_base[0]);
  988.     if (vs_base[0]->v.v_hasfillp)
  989.         vs_base[0] = make_fixnum(vs_base[0]->v.v_fillp);
  990.     else
  991.         FEerror("The vector ~S has no fill pointer.", 1, vs_base[0]);
  992. }
  993.  
  994. /*
  995.     Internal function for setting fill pointer.
  996. */
  997. siLfill_pointer_set()
  998. {
  999.     int i;
  1000.  
  1001.     check_arg(2);
  1002.     check_type_vector(&vs_base[0]);
  1003.     i = fixnnint(vs_base[1]);
  1004.     if (vs_base[0]->v.v_hasfillp)
  1005.         if (i > vs_base[0]->v.v_dim)
  1006.             FEerror("The fill-pointer ~S is too large",
  1007.                 1, vs_base[0]);
  1008.         else
  1009.             vs_base[0]->v.v_fillp = i;
  1010.     else
  1011.         FEerror("The vector ~S has no fill pointer.",
  1012.             1, vs_base[0]);
  1013.     vs_base[0] = vs_base[1];
  1014.     vs_top = vs_base + 1;
  1015. }
  1016.  
  1017. /*
  1018.     Internal function for replacing the contents of arrays:
  1019.  
  1020.         (si:replace-array old-array new-array).
  1021.  
  1022.     Used in ADJUST-ARRAY.
  1023. */
  1024. siLreplace_array()
  1025. {
  1026.     object old, new, displaced, dlist;
  1027.     int diff;
  1028.     struct dummy fw;
  1029.  
  1030.     check_arg(2);
  1031.     old = vs_base[0];
  1032.     new = vs_base[1];
  1033.     fw = old->d;
  1034.  
  1035.     if (type_of(old) != type_of(new))
  1036.         goto CANNOT;
  1037.     if (type_of(old) == t_array && old->a.a_rank != new->a.a_rank)
  1038.         goto CANNOT;
  1039. /*   Common lisp now allows adjustment of non adjustable arrays CLTLII 17.6
  1040.      if (!old->a.a_adjustable)
  1041.         FEerror("~S is not adjustable.", 1, old);
  1042. */        
  1043.     diff = (int)(new->a.a_self) - (int)(old->a.a_self);
  1044.     dlist = old->a.a_displaced->c.c_cdr;
  1045.     displaced = make_cons(new->a.a_displaced->c.c_car, dlist);
  1046.     vs_push(displaced);
  1047.     check_displaced(dlist, old, new->a.a_dim);
  1048.     adjust_displaced(old, diff);
  1049.     undisplace(old);
  1050.     switch (type_of(old)) {
  1051.     case t_array:
  1052.     case t_vector:
  1053.     case t_bitvector:
  1054.         old->a = new->a;
  1055.         break;
  1056.  
  1057.     case t_string:
  1058.         old->st = new->st;
  1059.         break;
  1060.  
  1061.     default:
  1062.         goto CANNOT;
  1063.     }
  1064.     
  1065.     /* restore the s and m fields overwritten by above assignments  */
  1066.     old->d = fw;
  1067.     old->a.a_displaced = displaced;
  1068.     /* prevent having two arrays with the same body--which are not related
  1069.         that would cause the gc to try to copy both arrays and there might
  1070.        not be enough space. */
  1071.     new->a.a_dim=0;
  1072.     new->a.a_self=0;
  1073.     vs_pop;
  1074.     vs_pop;
  1075.     return;
  1076.  
  1077. CANNOT:
  1078.     FEerror("Cannot replace the array ~S~%\
  1079. by the array ~S.", 2, old, new);
  1080. }
  1081.  
  1082. siLaset_by_cursor()
  1083. {
  1084.     object *base = vs_base;
  1085.     object x;
  1086.  
  1087.     check_arg(3);
  1088.     vs_base = vs_top;
  1089.     vs_push(base[0]);
  1090.     for (x = base[2];  !endp(x);  x = MMcdr(x))
  1091.         vs_push(MMcar(x));
  1092.     vs_push(base[1]);
  1093.     siLaset();
  1094. }
  1095.  
  1096. init_array_function()
  1097. {
  1098.     make_constant("ARRAY-RANK-LIMIT", make_fixnum(ARANKLIM));
  1099.     make_constant("ARRAY-DIMENSION-LIMIT", make_fixnum(ADIMLIM));
  1100.     make_constant("ARRAY-TOTAL-SIZE-LIMIT", make_fixnum(ATOTLIM));
  1101.  
  1102.     make_si_function("MAKE-PURE-ARRAY", siLmake_pure_array);
  1103.     make_si_function("MAKE-VECTOR", siLmake_vector);
  1104.     make_function("AREF", Laref);
  1105.     make_si_function("ASET", siLaset);
  1106.     make_function("ARRAY-ELEMENT-TYPE", Larray_element_type);
  1107.     make_function("ARRAY-RANK", Larray_rank);
  1108.     make_function("ARRAY-DIMENSION", Larray_dimension);
  1109.     make_function("ARRAY-TOTAL-SIZE", Larray_total_size);
  1110.     make_function("ADJUSTABLE-ARRAY-P", Ladjustable_array_p);
  1111.     make_si_function("DISPLACED-ARRAY-P", siLdisplaced_array_p);
  1112.     make_si_constant("CHAR-SIZE",make_fixnum(CHAR_SIZE));
  1113.     make_si_constant("SHORT-SIZE",make_fixnum(CHAR_SIZE*sizeof(short)));
  1114.     make_function("SVREF", Lsvref);
  1115.     make_si_function("SVSET", siLsvset);
  1116.     make_si_function("COPY-ARRAY-PORTION",siLcopy_array_portion);
  1117.     make_function("ARRAY-HAS-FILL-POINTER-P",
  1118.               Larray_has_fill_pointer_p);
  1119.     make_function("FILL-POINTER", Lfill_pointer);
  1120.     make_si_function("FILL-POINTER-SET", siLfill_pointer_set);
  1121.  
  1122.     make_si_function("REPLACE-ARRAY", siLreplace_array);
  1123.  
  1124.     make_si_function("ASET-BY-CURSOR", siLaset_by_cursor);
  1125. }
  1126.