/[gcl]/gcl/o/array.c
ViewVC logotype

Diff of /gcl/o/array.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.15 by camm, Sun Feb 9 22:35:17 2003 UTC revision 1.16 by camm, Sat Feb 15 00:38:28 2003 UTC
# Line 23  Foundation, 675 Mass Ave, Cambridge, MA Line 23  Foundation, 675 Mass Ave, Cambridge, MA
23  #include <string.h>  #include <string.h>
24  #include "include.h"  #include "include.h"
25    
26    static void
27    displace(object, object, int);
28    
29    static enum aelttype
30    Iarray_element_type(object);
31    
32    
33  /*  #define ARRAY_DIMENSION_LIMIT MOST_POSITIVE_FIXNUM */  /*  #define ARRAY_DIMENSION_LIMIT MOST_POSITIVE_FIXNUM */
34    
# Line 57  extern short aet_sizes[]; Line 63  extern short aet_sizes[];
63  #define N_FIXNUM_ARGS 6  #define N_FIXNUM_ARGS 6
64    
65  DEFUNO_NEW("AREF", object, fLaref, LISP, 1, ARRAY_RANK_LIMIT,  DEFUNO_NEW("AREF", object, fLaref, LISP, 1, ARRAY_RANK_LIMIT,
66         NONE, OO, II, II, II,Laref,(object x, int i, ...),"")         NONE, OO, II, II, II,void,Laref,(object x, int i, ...),"")
67  { int n = VFUN_NARGS;  { int n = VFUN_NARGS;
68    int i1;    int i1;
69    va_list ap;    va_list ap;
# Line 100  DEFUNO_NEW("AREF", object, fLaref, LISP, Line 106  DEFUNO_NEW("AREF", object, fLaref, LISP,
106    
107  }  }
108    
109  void  static void
110  fScheck_bounds_bounds(object x, int i)  fScheck_bounds_bounds(object x, int i)
111  {  {
112    switch (type_of(x)) {    switch (type_of(x)) {
# Line 115  fScheck_bounds_bounds(object x, int i) Line 121  fScheck_bounds_bounds(object x, int i)
121    }    }
122  }  }
123    
124  DEFUN_NEW("SVREF", object, fLsvref, LISP, 2, 2,  DEFUNO_NEW("SVREF", object, fLsvref, LISP, 2, 2,
125        ONE_VAL, OO, IO, OO,OO,(object x, unsigned int i),        ONE_VAL, OO, IO, OO,OO,void,Lsvref,(object x, unsigned int i),
126        "For array X and index I it returns (aref x i) ")        "For array X and index I it returns (aref x i) ")
127  {  {
128   if (type_of(x)==t_vector   if (type_of(x)==t_vector
# Line 128  DEFUN_NEW("SVREF", object, fLsvref, LISP Line 134  DEFUN_NEW("SVREF", object, fLsvref, LISP
134   return(Cnil);   return(Cnil);
135  }  }
136            
137  DEFUNO_NEW("ROW-MAJOR-AREF", object, fLrow_major_aref, LISP, 2, 2,  DEFUN_NEW("ROW-MAJOR-AREF", object, fLrow_major_aref, LISP, 2, 2,
138         NONE, OO, IO, OO,OO,Lrow_major_aref,(object x, int i),         NONE, OO, IO, OO,OO,(object x, int i),
139        "For array X and index I it returns (aref x i) as if x were \        "For array X and index I it returns (aref x i) as if x were \
140  1 dimensional, even though its rank may be bigger than 1")  1 dimensional, even though its rank may be bigger than 1")
141  {  {
# Line 253  DEFUN_NEW("ASET1", object, fSaset1, SI, Line 259  DEFUN_NEW("ASET1", object, fSaset1, SI,
259  }  }
260    
261  DEFUNO_NEW("ASET", object, fSaset, SI, 1, ARG_LIMIT, NONE, OO,  DEFUNO_NEW("ASET", object, fSaset, SI, 1, ARG_LIMIT, NONE, OO,
262         OO, OO, OO,siLaset,(object x,object ii,object y, ...),"")         OO, OO, OO,void,siLaset,(object x,object ii,object y, ...),"")
263  { int i1;  { int i1;
264    int n = VFUN_NARGS;    int n = VFUN_NARGS;
265    int i;    int i;
# Line 309  DEFUNO_NEW("ASET", object, fSaset, SI, 1 Line 315  DEFUNO_NEW("ASET", object, fSaset, SI, 1
315  }  }
316    
317  DEFUNO_NEW("SVSET", object, fSsvset, SI, 3, 3, NONE, OO, IO, OO,  DEFUNO_NEW("SVSET", object, fSsvset, SI, 3, 3, NONE, OO, IO, OO,
318         OO,siLsvset,(object x,int i,object val),"")         OO,void,siLsvset,(object x,int i,object val),"")
319  { if (TYPE_OF(x) != t_vector  { if (TYPE_OF(x) != t_vector
320        || DISPLACED_TO(x) != Cnil)        || DISPLACED_TO(x) != Cnil)
321      Wrong_type_error("simple array",0);      Wrong_type_error("simple array",0);
# Line 327  DEFUNO_NEW("SVSET", object, fSsvset, SI, Line 333  DEFUNO_NEW("SVSET", object, fSsvset, SI,
333  */  */
334    
335    
336  DEFUNO_NEW("MAKE-VECTOR1",object,fSmake_vector1,SI,3,8,NONE,OI,  DEFUN_NEW("MAKE-VECTOR1",object,fSmake_vector1,SI,3,8,NONE,OI,
337        IO,OO,OO,LSmake_vector1,(int n,int elt_type,object staticp,...),"")        IO,OO,OO,(int n,int elt_type,object staticp,...),"")
338        
339  {  {
340      int displaced_index_offset=0;      int displaced_index_offset=0;
# Line 461  DEFUN_NEW("GET-AELTTYPE",object,fSget_ae Line 467  DEFUN_NEW("GET-AELTTYPE",object,fSget_ae
467          static 6 &optional initial-element)          static 6 &optional initial-element)
468  */  */
469  DEFUNO_NEW("MAKE-VECTOR",object,fSmake_vector,SI,7,8,NONE,  DEFUNO_NEW("MAKE-VECTOR",object,fSmake_vector,SI,7,8,NONE,
470         OO,OO,OO,OO,siLmake_vector,(object x0,object x1,object x2,object x3,object x4,object x5,object x6,...),"")         OO,OO,OO,OO,void,siLmake_vector,(object x0,object x1,object x2,object x3,object x4,object x5,object x6,...),"")
471  {int narg=VFUN_NARGS;  {int narg=VFUN_NARGS;
472   object initial_elt;   object initial_elt;
473   va_list ap;   va_list ap;
# Line 533  DEFUN_NEW("MAKE-ARRAY1",object,fSmake_ar Line 539  DEFUN_NEW("MAKE-ARRAY1",object,fSmake_ar
539  */  */
540    
541  /*  DEFUNO_NEW("ARRAY-DISPLACEMENT1",object,fSarray_displacement,SI,1,1, */  /*  DEFUNO_NEW("ARRAY-DISPLACEMENT1",object,fSarray_displacement,SI,1,1, */
542  /*        NONE,OO,OO,OO,OO,siLarray_displacement,"") */  /*        NONE,OO,OO,OO,OO,void,siLarray_displacement,"") */
543  /*       (object array) { */  /*       (object array) { */
544    
545  /*    object a; */  /*    object a; */
# Line 556  DEFUN_NEW("MAKE-ARRAY1",object,fSmake_ar Line 562  DEFUN_NEW("MAKE-ARRAY1",object,fSmake_ar
562    
563  /*  } */  /*  } */
564    
565  void  static void
566  Larray_displacement(void) {  Larray_displacement(void) {
567    
568    object array,a;    object array,a;
# Line 611  Larray_displacement(void) { Line 617  Larray_displacement(void) {
617  (setq z2 (make-array 2 :displaced-to y))  ;; z2->displaced= (y)  (setq z2 (make-array 2 :displaced-to y))  ;; z2->displaced= (y)
618  */  */
619    
620  void  static void
621  displace(object from_array, object dest_array, int offset)  displace(object from_array, object dest_array, int offset)
622  {  {
623    enum aelttype typ;    enum aelttype typ;
# Line 651  displace(object from_array, object dest_ Line 657  displace(object from_array, object dest_
657            
658    
659    
660  enum aelttype  static enum aelttype
661  Iarray_element_type(object x)  Iarray_element_type(object x)
662  {enum aelttype t=aet_last;  {enum aelttype t=aet_last;
663    switch(TYPE_OF(x))    switch(TYPE_OF(x))
# Line 677  Iarray_element_type(object x) Line 683  Iarray_element_type(object x)
683        at the  DISPLACED_INDEX_OFFSET        at the  DISPLACED_INDEX_OFFSET
684        */        */
685    
686  void  /* static void */
687  Idisplace_array(object from, object to, int displaced_index_offset)  /* Idisplace_array(object from, object to, int displaced_index_offset) */
688  {  /* { */
689    enum aelttype t1,t2;  /*   enum aelttype t1,t2; */
690    t1 = Iarray_element_type(from);  /*   t1 = Iarray_element_type(from); */
691    t2 = Iarray_element_type(to);  /*   t2 = Iarray_element_type(to); */
692    if (t1 != t2)  /*   if (t1 != t2) */
693      FEerror("Attempt to displace arrays of one type to arrays of another type",0);  /*     FEerror("Attempt to displace arrays of one type to arrays of another type",0); */
694    if (to->a.a_dim > from->a.a_dim - displaced_index_offset)  /*   if (to->a.a_dim > from->a.a_dim - displaced_index_offset) */
695      FEerror("To array not large enough for displacement",0);  /*     FEerror("To array not large enough for displacement",0); */
696    {BEGIN_NO_INTERRUPT;  /*   {BEGIN_NO_INTERRUPT; */
697     from->a.a_displaced = make_cons(to,Cnil);  /*    from->a.a_displaced = make_cons(to,Cnil); */
698     if (to->a.a_displaced == Cnil)  /*    if (to->a.a_displaced == Cnil) */
699       to->a.a_displaced = make_cons(Cnil,Cnil);  /*      to->a.a_displaced = make_cons(Cnil,Cnil); */
700     DISPLACED_FROM(to) = make_cons(from,DISPLACED_FROM(to));  /*    DISPLACED_FROM(to) = make_cons(from,DISPLACED_FROM(to)); */
701                
702     if (t1 == aet_bit) {  /*    if (t1 == aet_bit) { */
703       displaced_index_offset += BV_OFFSET(to);  /*      displaced_index_offset += BV_OFFSET(to); */
704       from->bv.bv_self = to->bv.bv_self + displaced_index_offset/BV_BITS;  /*      from->bv.bv_self = to->bv.bv_self + displaced_index_offset/BV_BITS; */
705       SET_BV_OFFSET(from, displaced_index_offset%BV_BITS);  /*      SET_BV_OFFSET(from, displaced_index_offset%BV_BITS); */
706     }  /*    } */
707     else  /*    else */
708       from->st.st_self = ARRAY_BODY_PTR(to,displaced_index_offset);  /*      from->st.st_self = ARRAY_BODY_PTR(to,displaced_index_offset); */
709     END_NO_INTERRUPT;  /*    END_NO_INTERRUPT; */
710   }  /*  } */
711    
712  }  /* } */
713    
714  /* add diff to body of x and arrays diisplaced to it */  /* add diff to body of x and arrays diisplaced to it */
715    
# Line 725  adjust_displaced(object x, int diff) Line 731  adjust_displaced(object x, int diff)
731        type.        type.
732        */        */
733    
734  char *  static char *
735  raw_aet_ptr(object x, short int typ)  raw_aet_ptr(object x, short int typ)
736  {  /* doubles are the largest raw type */  {  /* doubles are the largest raw type */
737    static double u;    static double u;
# Line 885  array_allocself(object x, int staticp, o Line 891  array_allocself(object x, int staticp, o
891  }  }
892    
893  DEFUNO_NEW("FILL-POINTER-SET",object,fSfill_pointer_set,SI,2,2,  DEFUNO_NEW("FILL-POINTER-SET",object,fSfill_pointer_set,SI,2,2,
894         NONE,OO,IO,OO,OO,siLfill_pointer_set,(object x,int i),"")         NONE,OO,IO,OO,OO,void,siLfill_pointer_set,(object x,int i),"")
895  {  {
896    
897      if (!(TS_MEMBER(type_of(x),TS(t_vector)|      if (!(TS_MEMBER(type_of(x),TS(t_vector)|
# Line 906  DEFUNO_NEW("FILL-POINTER-SET",object,fSf Line 912  DEFUNO_NEW("FILL-POINTER-SET",object,fSf
912  }  }
913    
914  DEFUNO_NEW("FILL-POINTER",object,fLfill_pointer,LISP,1,1,NONE,OO,  DEFUNO_NEW("FILL-POINTER",object,fLfill_pointer,LISP,1,1,NONE,OO,
915         OO,OO,OO,Lfill_pointer,(object x),"")         OO,OO,OO,void,Lfill_pointer,(object x),"")
916  {  {
917    if (!(TS_MEMBER(type_of(x),TS(t_vector)|    if (!(TS_MEMBER(type_of(x),TS(t_vector)|
918                      TS(t_bitvector)|                      TS(t_bitvector)|
# Line 944  DEFUN_NEW("ARRAY-HAS-FILL-POINTER-P",obj Line 950  DEFUN_NEW("ARRAY-HAS-FILL-POINTER-P",obj
950  */  */
951    
952  DEFUNO_NEW("ARRAY-ELEMENT-TYPE",object,fLarray_element_type,  DEFUNO_NEW("ARRAY-ELEMENT-TYPE",object,fLarray_element_type,
953         LISP,1,1,NONE,OO,OO,OO,OO,Larray_element_type,(object x),"")         LISP,1,1,NONE,OO,OO,OO,OO,void,Larray_element_type,(object x),"")
954  { enum aelttype t;  { enum aelttype t;
955    t = Iarray_element_type(x);    t = Iarray_element_type(x);
956    return * aet_types[(int)t].namep;    return * aet_types[(int)t].namep;
957  }  }
958    
959  DEFUNO_NEW("ADJUSTABLE-ARRAY-P",object,fLadjustable_array_p,  DEFUNO_NEW("ADJUSTABLE-ARRAY-P",object,fLadjustable_array_p,
960         LISP,1,1,NONE,OO,OO,OO,OO,Ladjustable_array_p,(object x),"")         LISP,1,1,NONE,OO,OO,OO,OO,void,Ladjustable_array_p,(object x),"")
961  { return sLt;  { return sLt;
962  }  }
963    
964  DEFUNO_NEW("DISPLACED-ARRAY-P",object,fSdisplaced_array_p,SI,1,  DEFUNO_NEW("DISPLACED-ARRAY-P",object,fSdisplaced_array_p,SI,1,
965         1,NONE,OO,OO,OO,OO,siLdisplaced_array_p,(object x),"")         1,NONE,OO,OO,OO,OO,void,siLdisplaced_array_p,(object x),"")
966  { IisArray(x);  { IisArray(x);
967    return (x->a.a_displaced == Cnil ? Cnil : sLt);    return (x->a.a_displaced == Cnil ? Cnil : sLt);
968  }  }
969    
970  DEFUNO_NEW("ARRAY-RANK",object,fLarray_rank,LISP,1,1,NONE,OO,OO,OO,  DEFUNO_NEW("ARRAY-RANK",object,fLarray_rank,LISP,1,1,NONE,OO,OO,OO,
971         OO,Larray_rank,(object x),"")         OO,void,Larray_rank,(object x),"")
972  { if (type_of(x) == t_array)  { if (type_of(x) == t_array)
973      return make_fixnum(x->a.a_rank);      return make_fixnum(x->a.a_rank);
974    IisArray(x);    IisArray(x);
# Line 970  DEFUNO_NEW("ARRAY-RANK",object,fLarray_r Line 976  DEFUNO_NEW("ARRAY-RANK",object,fLarray_r
976  }  }
977    
978  DEFUNO_NEW("ARRAY-DIMENSION",object,fLarray_dimension,LISP,2,2,  DEFUNO_NEW("ARRAY-DIMENSION",object,fLarray_dimension,LISP,2,2,
979         NONE,OO,IO,OO,OO,Larray_dimension,(object x,int i),"")         NONE,OO,IO,OO,OO,void,Larray_dimension,(object x,int i),"")
980  {  {
981    if (type_of(x) == t_array)    if (type_of(x) == t_array)
982     {  if ((unsigned int)i >= x->a.a_rank)     {  if ((unsigned int)i >= x->a.a_rank)
# Line 981  DEFUNO_NEW("ARRAY-DIMENSION",object,fLar Line 987  DEFUNO_NEW("ARRAY-DIMENSION",object,fLar
987     return make_fixnum(x->v.v_dim);     return make_fixnum(x->v.v_dim);
988  }  }
989    
990  void  static void
991  Icheck_displaced(object displaced_list, object ar, int dim)  Icheck_displaced(object displaced_list, object ar, int dim)
992  {  {
993    while (displaced_list!=Cnil)    while (displaced_list!=Cnil)
# Line 1010  Icheck_displaced(object displaced_list, Line 1016  Icheck_displaced(object displaced_list,
1016    Destroy the displacement from AR    Destroy the displacement from AR
1017        
1018    */    */
1019  void  /* static void */
1020  Iundisplace(object ar)  /* Iundisplace(object ar) */
1021  { object *p,x;  /* { object *p,x;  */
1022        
1023    if ((x = DISPLACED_TO(ar)) == Cnil ||  /*   if ((x = DISPLACED_TO(ar)) == Cnil || */
1024        ar->a.a_displaced->d.m == FREE)  /*       ar->a.a_displaced->d.m == FREE) */
1025      return;  /*     return; */
1026    {BEGIN_NO_INTERRUPT;  /*   {BEGIN_NO_INTERRUPT; */
1027     DISPLACED_TO(ar) = Cnil;  /*    DISPLACED_TO(ar) = Cnil; */
1028     p = &(DISPLACED_FROM(x)) ;  /*    p = &(DISPLACED_FROM(x)) ; */
1029     /* walk through the displaced from list and delete AR */     /* walk through the displaced from list and delete AR */
1030     while(1)  /*    while(1) */
1031       { if ((*p)->d.m == FREE  /*      { if ((*p)->d.m == FREE */
1032             || *p == Cnil)  /*         || *p == Cnil) */
1033          goto retur;  /*      goto retur; */
1034           if((Mcar(*p) == ar))  /*       if((Mcar(*p) == ar)) */
1035           { *p = Mcdr(*p);  /*       { *p = Mcdr(*p); */
1036             goto retur;}  /*         goto retur;} */
1037           p = &(Mcdr(*p));  /*       p = &(Mcdr(*p)); */
1038         }  /*        } */
1039   retur:  /*  retur: */
1040     END_NO_INTERRUPT;  /*    END_NO_INTERRUPT; */
1041     return;  /*    return; */
1042   }  /*  } */
1043  }  /* } */
1044    
1045  DEFUNO_NEW("REPLACE-ARRAY",object,fSreplace_array,SI,2,2,NONE,  DEFUNO_NEW("REPLACE-ARRAY",object,fSreplace_array,SI,2,2,NONE,
1046         OO,OO,OO,OO,siLreplace_array,(object old,object new),"")         OO,OO,OO,OO,void,siLreplace_array,(object old,object new),"")
1047  { struct dummy fw ;  { struct dummy fw ;
1048    fw = old->d;    fw = old->d;
1049    
# Line 1072  DEFUNO_NEW("REPLACE-ARRAY",object,fSrepl Line 1078  DEFUNO_NEW("REPLACE-ARRAY",object,fSrepl
1078    return old;    return old;
1079  }  }
1080    
1081  DEFUNO_NEW("ARRAY-TOTAL-SIZE",object,fLarray_total_size,LISP,1,1,  DEFUN_NEW("ARRAY-TOTAL-SIZE",object,fLarray_total_size,LISP,1,1,
1082         NONE,OO,OO,OO,OO,Larray_total_size,(object x),"")         NONE,OO,OO,OO,OO,(object x),"")
1083  { x = IisArray(x);  { x = IisArray(x);
1084    return make_fixnum(x->a.a_dim);    return make_fixnum(x->a.a_dim);
1085  }  }
1086    
1087    
1088  DEFUNO_NEW("ASET-BY-CURSOR",object,fSaset_by_cursor,SI,3,3,  DEFUN_NEW("ASET-BY-CURSOR",object,fSaset_by_cursor,SI,3,3,
1089         NONE,OO,OO,OO,OO,siLaset_by_cursor,(object array,object val,object cursor),"")         NONE,OO,OO,OO,OO,(object array,object val,object cursor),"")
1090  {  {
1091          object x;          object x;
1092          int i;          int i;

Legend:
Removed from v.1.15  
changed lines
  Added in v.1.16

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26