/[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.38 by camm, Sat Jul 23 08:53:44 2005 UTC revision 1.39 by camm, Wed Sep 7 02:52:43 2005 UTC
# Line 146  DEFUNO_NEW("ROW-MAJOR-AREF", object, fLr Line 146  DEFUNO_NEW("ROW-MAJOR-AREF", object, fLr
146        i += BV_OFFSET(x);        i += BV_OFFSET(x);
147        return make_fixnum(BITREF(x, i));        return make_fixnum(BITREF(x, i));
148      case aet_fix:      case aet_fix:
149        case aet_nnfix:
150        return make_fixnum(x->fixa.fixa_self[i]);        return make_fixnum(x->fixa.fixa_self[i]);
151      case aet_sf:      case aet_sf:
152        return make_shortfloat(x->sfa.sfa_self[i]);        return make_shortfloat(x->sfa.sfa_self[i]);
153      case aet_lf:      case aet_lf:
154        return make_longfloat(x->lfa.lfa_self[i]);        return make_longfloat(x->lfa.lfa_self[i]);
155      case aet_char:      case aet_char:
156        case aet_nnchar:
157        return small_fixnum(x->st.st_self[i]);        return small_fixnum(x->st.st_self[i]);
158      case aet_uchar:      case aet_uchar:
159        return small_fixnum(x->ust.ust_self[i]);        return small_fixnum(x->ust.ust_self[i]);
160      case aet_short:      case aet_short:
161        case aet_nnshort:
162        return make_fixnum(SHORT_GCL(x, i));        return make_fixnum(SHORT_GCL(x, i));
163      case aet_ushort:      case aet_ushort:
164        return make_fixnum(USHORT_GCL(x, i));        return make_fixnum(USHORT_GCL(x, i));
# Line 209  DEFUN_NEW("ASET1", object, fSaset1, SI, Line 212  DEFUN_NEW("ASET1", object, fSaset1, SI,
212               goto AGAIN_BIT;}               goto AGAIN_BIT;}
213         break;}         break;}
214      case aet_fix:      case aet_fix:
215        case aet_nnfix:
216        ASSURE_TYPE(val,t_fixnum);        ASSURE_TYPE(val,t_fixnum);
217        (x->fixa.fixa_self[i]) = Mfix(val);        (x->fixa.fixa_self[i]) = Mfix(val);
218        break;        break;
# Line 221  DEFUN_NEW("ASET1", object, fSaset1, SI, Line 225  DEFUN_NEW("ASET1", object, fSaset1, SI,
225        (x->lfa.lfa_self[i]) = Mlf(val);        (x->lfa.lfa_self[i]) = Mlf(val);
226        break;        break;
227      case aet_char:      case aet_char:
228        case aet_nnchar:
229        ASSURE_TYPE(val,t_fixnum);        ASSURE_TYPE(val,t_fixnum);
230        x->st.st_self[i] = Mfix(val);        x->st.st_self[i] = Mfix(val);
231        break;        break;
# Line 229  DEFUN_NEW("ASET1", object, fSaset1, SI, Line 234  DEFUN_NEW("ASET1", object, fSaset1, SI,
234        (x->ust.ust_self[i])= Mfix(val);        (x->ust.ust_self[i])= Mfix(val);
235        break;        break;
236      case aet_short:      case aet_short:
237        case aet_nnshort:
238        ASSURE_TYPE(val,t_fixnum);        ASSURE_TYPE(val,t_fixnum);
239        SHORT_GCL(x, i) = Mfix(val);        SHORT_GCL(x, i) = Mfix(val);
240        break;        break;
# Line 447  static struct { char * dflt; object *nam Line 453  static struct { char * dflt; object *nam
453      {(char *)   &DFLT_aet_ch, &sLstring_char,},/*  string-char  */      {(char *)   &DFLT_aet_ch, &sLstring_char,},/*  string-char  */
454      {(char *)   &DFLT_aet_fix, &sLbit,},                /*  bit  */      {(char *)   &DFLT_aet_fix, &sLbit,},                /*  bit  */
455      {(char *)   &DFLT_aet_fix,  &sLfixnum,},    /*  fixnum  */      {(char *)   &DFLT_aet_fix,  &sLfixnum,},    /*  fixnum  */
456        {(char *)   &DFLT_aet_fix,  &sLnon_negative_fixnum,},       /*  non-neg fixnum  */
457      {(char *)   &DFLT_aet_sf, &sLshort_float,},                 /*  short-float  */      {(char *)   &DFLT_aet_sf, &sLshort_float,},                 /*  short-float  */
458      {(char *)   &DFLT_aet_lf, &sLlong_float,},  /*  long-float  */      {(char *)   &DFLT_aet_lf, &sLlong_float,},  /*  long-float  */
459      {(char *)   &DFLT_aet_char,&sLsigned_char,},               /* signed char */      {(char *)   &DFLT_aet_char,&sLsigned_char,},               /* signed char */
460      {(char *)    &DFLT_aet_char,&sLunsigned_char,},               /* unsigned char */      {(char *)   &DFLT_aet_char,&sLnon_negative_char,},               /* non-neg char */
461        {(char *)   &DFLT_aet_char,&sLunsigned_char,},               /* unsigned char */
462      {(char *)   &DFLT_aet_short,&sLsigned_short,},              /* signed short */      {(char *)   &DFLT_aet_short,&sLsigned_short,},              /* signed short */
463        {(char *)   &DFLT_aet_short,&sLnon_negative_short,},              /* non-neg short */
464      {(char *)   &DFLT_aet_short, &sLunsigned_short},    /*  unsigned short   */      {(char *)   &DFLT_aet_short, &sLunsigned_short},    /*  unsigned short   */
465          };          };
466    
# Line 460  DEFUN_NEW("GET-AELTTYPE",object,fSget_ae Line 469  DEFUN_NEW("GET-AELTTYPE",object,fSget_ae
469    for (i=0 ; i <   aet_last ; i++)    for (i=0 ; i <   aet_last ; i++)
470      if (x == * aet_types[i].namep)      if (x == * aet_types[i].namep)
471        return make_fixnum((enum aelttype) i);        return make_fixnum((enum aelttype) i);
472    if (x == sLlong_float || x == sLsingle_float || x == sLdouble_float)    if (x == sLsingle_float || x == sLdouble_float)
473      return make_fixnum(aet_lf);      return make_fixnum(aet_lf);
474    if (x==sLnon_negative_char)    if (x==sLnegative_char)
475      return make_fixnum(aet_char);      return make_fixnum(aet_char);
476    if (x==sLnon_negative_short)    if (x==sLnegative_short)
477      return make_fixnum(aet_short);      return make_fixnum(aet_short);
478    if (x==sLnon_negative_fixnum)    if (x==sLnegative_fixnum || x==sLsigned_fixnum)
479      return make_fixnum(aet_fix);      return make_fixnum(aet_fix);
480    return make_fixnum(aet_object);    return make_fixnum(aet_object);
481  }  }
# Line 798  raw_aet_ptr(object x, short int typ) Line 807  raw_aet_ptr(object x, short int typ)
807      u.i=-Mfix(x);      u.i=-Mfix(x);
808      break;      break;
809    case aet_fix:        case aet_fix:    
810      case aet_nnfix:    
811      /* STORE_TYPED(&u,fixnum, Mfix(x)); */      /* STORE_TYPED(&u,fixnum, Mfix(x)); */
812      u.i=Mfix(x);      u.i=Mfix(x);
813      break;      break;
# Line 810  raw_aet_ptr(object x, short int typ) Line 820  raw_aet_ptr(object x, short int typ)
820      u.d=Mlf(x);      u.d=Mlf(x);
821      break;      break;
822    case aet_char:      case aet_char:  
823      case aet_nnchar:  
824      /* STORE_TYPED(&u, char, Mfix(x)); */      /* STORE_TYPED(&u, char, Mfix(x)); */
825      u.c=(char)Mfix(x);      u.c=(char)Mfix(x);
826      break;      break;
# Line 818  raw_aet_ptr(object x, short int typ) Line 829  raw_aet_ptr(object x, short int typ)
829      u.uc=(unsigned char)Mfix(x);      u.uc=(unsigned char)Mfix(x);
830      break;      break;
831    case aet_short:      case aet_short:  
832      case aet_nnshort:  
833      /* STORE_TYPED(&u, short, Mfix(x)); */      /* STORE_TYPED(&u, short, Mfix(x)); */
834      u.s=(short)Mfix(x);      u.s=(short)Mfix(x);
835      break;      break;
# Line 857  gset(void *p1, void *val, int n, int typ Line 869  gset(void *p1, void *val, int n, int typ
869      case aet_ch:     GSET(p1,n,char,val);      case aet_ch:     GSET(p1,n,char,val);
870        /* Note n is number of fixnum WORDS for bit */        /* Note n is number of fixnum WORDS for bit */
871      case aet_bit:    GSET(p1,n,fixnum,val);      case aet_bit:    GSET(p1,n,fixnum,val);
872      case aet_fix:    GSET(p1,n,fixnum,val);      case aet_fix:case aet_nnfix:    GSET(p1,n,fixnum,val);
873      case aet_sf:     GSET(p1,n,shortfloat,val);      case aet_sf:     GSET(p1,n,shortfloat,val);
874      case aet_lf:     GSET(p1,n,longfloat,val);      case aet_lf:     GSET(p1,n,longfloat,val);
875      case aet_char:   GSET(p1,n,char,val);      case aet_char:case aet_nnchar:   GSET(p1,n,char,val);
876      case aet_uchar:  GSET(p1,n,unsigned char,val);      case aet_uchar:  GSET(p1,n,unsigned char,val);
877      case aet_short:  GSET(p1,n,short,val);      case aet_short:case aet_nnshort:  GSET(p1,n,short,val);
878      case aet_ushort: GSET(p1,n,unsigned short,val);      case aet_ushort: GSET(p1,n,unsigned short,val);
879      default:         FEerror("bad elttype",0);      default:         FEerror("bad elttype",0);
880      }      }
# Line 942  array_allocself(object x, int staticp, o Line 954  array_allocself(object x, int staticp, o
954                  break;                  break;
955          case aet_ch:          case aet_ch:
956          case aet_char:          case aet_char:
957            case aet_nnchar:
958          case aet_uchar:          case aet_uchar:
959                  x->st.st_self = AR_ALLOC(*fun,n,char);                  x->st.st_self = AR_ALLOC(*fun,n,char);
960                  break;                  break;
961          case aet_short:          case aet_short:
962            case aet_nnshort:
963          case aet_ushort:          case aet_ushort:
964                  x->ust.ust_self = (unsigned char *) AR_ALLOC(*fun,n,short);                  x->ust.ust_self = (unsigned char *) AR_ALLOC(*fun,n,short);
965                  break;                  break;
# Line 953  array_allocself(object x, int staticp, o Line 967  array_allocself(object x, int staticp, o
967                  n = (n+W_SIZE-1)/W_SIZE;                  n = (n+W_SIZE-1)/W_SIZE;
968                  SET_BV_OFFSET(x,0);                  SET_BV_OFFSET(x,0);
969          case aet_fix:          case aet_fix:
970            case aet_nnfix:
971                  x->fixa.fixa_self = AR_ALLOC(*fun,n,fixnum);                  x->fixa.fixa_self = AR_ALLOC(*fun,n,fixnum);
972                  break;                  break;
973          case aet_sf:          case aet_sf:
# Line 1039  DEFUNO_NEW("ADJUSTABLE-ARRAY-P",object,f Line 1054  DEFUNO_NEW("ADJUSTABLE-ARRAY-P",object,f
1054         LISP,1,1,NONE,OO,OO,OO,OO,void,Ladjustable_array_p,(object x),"")         LISP,1,1,NONE,OO,OO,OO,OO,void,Ladjustable_array_p,(object x),"")
1055  {  {
1056    IisArray(x);    IisArray(x);
1057    return sLt;    switch (type_of(x)) {
1058      case t_array:
1059        x=x->a.a_adjustable ? Ct : Cnil;
1060        break;
1061      case t_string:
1062        x=x->st.st_adjustable ? Ct : Cnil;
1063        break;
1064      case t_vector:
1065        x=x->v.v_adjustable ? Ct : Cnil;
1066        break;
1067      case t_bitvector:
1068        x=x->bv.bv_adjustable ? Ct : Cnil;
1069        break;
1070      default:
1071        FEerror("Bad array type",0);
1072        break;
1073      }
1074      return x;
1075  }  }
1076    
1077  DEFUNO_NEW("DISPLACED-ARRAY-P",object,fSdisplaced_array_p,SI,1,  DEFUNO_NEW("DISPLACED-ARRAY-P",object,fSdisplaced_array_p,SI,1,

Legend:
Removed from v.1.38  
changed lines
  Added in v.1.39

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