/* Scheme implementation intended for JACAL.
   Copyright (C) 1992 Aubrey Jaffer.

/* The set of uniform vector types is:
 Vector of:		 Called:
char			string
boolean			bvect
signed int		ivect
unsigned int		uvect
float			fvect
double			dvect
complex double		cvect
*/

#include <stdio.h>
#include "scm.h"

void uvprin1(exp,f)
     SCM exp;
     FILE *f;
{
  register long i, j, w;
  lputs("#*",f);
  for(i=0;i<(LENGTH(exp))/LONG_BIT;i++) {
    w = VELTS(exp)[i];
    for(j=LONG_BIT;j;j--) {
      lputc(w&1?'1':'0',f);
      w >>= 1;
    }
  }
  j = LENGTH(exp)%LONG_BIT;
  if (j) {
    w = VELTS(exp)[LENGTH(exp)/LONG_BIT];
    for(;j;j--) {
      lputc(w&1?'1':'0',f);
      w >>= 1;
    }
  }
}

static char s_make_uve[]="make-uniform-vector";
SCM make_uve(k,prot)
SCM k,prot;
{
  SCM v;
  register long i;
  long type;
  ASSERT(INUMP(k),k,ARG1,s_make_uve);
  if (BOOL_T == prot) {
    i = sizeof(long)*((INUM(k)+LONG_BIT-1)/LONG_BIT);
    type = tc7_bvect;
  }
  else if ICHRP(prot) {
    i = sizeof(char)*INUM(k);
    type = tc7_string;
  }
  else if INUMP(prot) {
    i = sizeof(long)*INUM(k);
    if (prot>0) type = tc7_uvect;
    else type=tc7_ivect;
  }
  else if (NIMP(prot)
#ifdef FLOATS
	   && !INEXP(prot)
#endif
	   )
    return make_vector(k,UNDEFINED); /* no special vector */
#ifdef FLOATS
# ifdef SINGLES
  else if SINGP(prot) {
    i = sizeof(float)*INUM(k);
    type = tc7_fvect;
  }
# endif
  else if (CPLXP(prot)) {
    i = 2*sizeof(double)*INUM(k);
    type = tc7_cvect;
  }
  else {
    i = sizeof(double)*INUM(k);
    type = tc7_dvect;
  }
#endif
  NEWCELL(v);
  DEFER_INTS;
  SETCHARS(v,must_malloc(i,s_vector));
  SETLENGTH(v, INUM(k), type);
  ALLOW_INTS;
  return v;
}
static char s_uve_len[]="uniform-vector-length";
SCM uve_len(v)
     SCM v;
{
  ASRTGO(NIMP(v),badarg1);
  switch TYP7(v) {
  default: badarg1: wta(v,(char *)ARG1,s_uve_len);
  case tc7_bvect:
  case tc7_string:
  case tc7_uvect:
  case tc7_ivect:
  case tc7_fvect:
  case tc7_dvect:
  case tc7_cvect:
  case tc7_vector:
    return MAKINUM(LENGTH(v));
  }
}
static char s_uve_ref[]="uniform-vector-ref";
SCM uve_ref(v,k)
  SCM v,k;
{
  ASRTGO(NIMP(v),badarg1);
  ASSERT(INUMP(k),k,ARG2,s_uve_ref);
  ASSERT((INUM(k) < LENGTH(v)) && (INUM(k) >= 0),
	 k,OUTOFRANGE,s_uve_ref);
  switch TYP7(v) {
  default: badarg1: wta(v,(char *)ARG1,s_uve_ref);
  case tc7_bvect:
    if (VELTS(v)[INUM(k)/LONG_BIT]&(1L<<(INUM(k)%LONG_BIT)))
      return BOOL_T;
    else return BOOL_F;
  case tc7_string: return MAKICHR(CHARS(v)[INUM(k)]);
  case tc7_uvect:
  case tc7_ivect: return MAKINUM(VELTS(v)[INUM(k)]);
#ifdef FLOATS
#ifdef SINGLES
  case tc7_fvect: return makdbl(((float *)CDR(v))[INUM(k)],0.0);
#endif
  case tc7_dvect: return makdbl(((double *)CDR(v))[INUM(k)],0.0);
  case tc7_cvect:
    return makdbl(((double *)CDR(v))[2*INUM(k)],
		  ((double *)CDR(v))[2*INUM(k)+1]);
#endif
  case tc7_vector: return VELTS(v)[((long) INUM(k))];
  }
}
static char s_uve_set[]="uniform-vector-set!";
SCM uve_set(v,k,obj)
SCM v,k,obj;
{
  ASRTGO(NIMP(v),badarg1);
  ASSERT(INUMP(k),k,ARG2,s_uve_set);
  ASSERT((INUM(k) < LENGTH(v)) && (INUM(k) >= 0), k,OUTOFRANGE,s_uve_set);
  switch TYP7(v) {
  default: badarg1: wta(v,(char *)ARG1,s_uve_set);
  case tc7_bvect:
    if (BOOL_F == obj)
      VELTS(v)[INUM(k)/LONG_BIT] &= ~(1L<<(INUM(k)%LONG_BIT));
    else if (BOOL_T == obj)
      VELTS(v)[INUM(k)/LONG_BIT] |= (1L<<(INUM(k)%LONG_BIT));
    else badarg3: wta(obj,(char *)ARG3,s_uve_set);
    break;
  case tc7_string: ASRTGO(ICHRP(obj),badarg3);
    CHARS(v)[INUM(k)] = ICHR(obj); break;
  case tc7_uvect: ASRTGO(INUM(obj)>=0,badarg3);
  case tc7_ivect: ASRTGO(INUMP(obj),badarg3);
    VELTS(v)[INUM(k)] = INUM(obj); break;
#ifdef FLOATS
#ifdef SINGLES
  case tc7_fvect: ASRTGO(NIMP(obj)&&REALP(obj),badarg3);
    ((float *)CDR(v))[INUM(k)] = REALPART(obj); break;
#endif
  case tc7_dvect: ASRTGO(NIMP(obj)&&REALP(obj),badarg3);
    ((double *)CDR(v))[INUM(k)] = REALPART(obj); break;
  case tc7_cvect: ASRTGO(NIMP(obj)&&INEXP(obj),badarg3);
    ((double *)CDR(v))[2*INUM(k)] = REALPART(obj);
    ((double *)CDR(v))[2*INUM(k)+1] = CPLXP(obj)?IMAG(obj):0.0; break;
#endif
  case tc7_vector: VELTS(v)[((long) INUM(k))] = obj; break;
  }
  return UNSPECIFIED;
}

static char s_uve_fill[]="uniform-vector-fill!";
SCM uve_fill(v,obj)
SCM v,obj;
{
  register long k;
  ASRTGO(NIMP(v),badarg1);
  k = LENGTH(v);
  switch TYP7(v) {
  default: badarg1: wta(v,(char *)ARG1,s_uve_fill);
  case tc7_bvect:
    if (BOOL_F == obj)
      for (k=(k+LONG_BIT-1)/LONG_BIT;k--;)
	VELTS(v)[k] = 0L;
    else if (BOOL_T == obj)
      for (k=(k+LONG_BIT-1)/LONG_BIT;k--;)
	VELTS(v)[k] = ~0L;
    else badarg2: wta(obj,(char *)ARG2,s_uve_fill);
    break;
  case tc7_string: ASRTGO(ICHRP(obj),badarg2);
    while (k--) CHARS(v)[k] = ICHR(obj);
    break;
  case tc7_uvect: ASRTGO(INUM(obj)>=0,badarg2);
  case tc7_ivect: ASRTGO(INUMP(obj),badarg2);
    while (k--) VELTS(v)[k] = INUM(obj);
    break;
#ifdef FLOATS
#ifdef SINGLES
  case tc7_fvect: ASRTGO(NIMP(obj)&&REALP(obj),badarg2);
    while (k--) ((float *)CDR(v))[k] = REALPART(obj);
    break;
#endif
  case tc7_dvect: ASRTGO(NIMP(obj)&&REALP(obj),badarg2);
    while (k--) ((double *)CDR(v))[k] = REALPART(obj);
    break;
  case tc7_cvect: ASRTGO(NIMP(obj)&&INEXP(obj),badarg2);
    while (k--) {
      ((double *)CDR(v))[2*k] = REALPART(obj);
      ((double *)CDR(v))[2*k+1] = CPLXP(obj)?IMAG(obj):0.0;
      }
    break;
#endif
  case tc7_vector:
    while (k--) VELTS(v)[k] = obj;
    break;
  }
  return UNSPECIFIED;
}

static char s_uve_rd[]="uniform-vector-read!";
SCM uve_read(v,port)
SCM v,port;
{
  long sz, len;
  if UNBNDP(port) port = cur_inp;
  else ASSERT(NIMP(port) && OPINPORTP(port),port,ARG2,s_uve_rd);
  ASRTGO(NIMP(v),badarg1);
  len = LENGTH(v);
  switch TYP7(v) {
  default: badarg1: wta(v,(char *)ARG1,s_uve_rd);
  case tc7_string:
    sz = sizeof(char);
    break;
  case tc7_bvect:
    len = (len+LONG_BIT-1)/LONG_BIT;
  case tc7_uvect:
  case tc7_ivect:
    sz = sizeof(long);
    break;
#ifdef FLOATS
#ifdef SINGLES
  case tc7_fvect:
    sz = sizeof(float);
    break;
#endif
  case tc7_dvect:
    sz = sizeof(double);
    break;
  case tc7_cvect:
    sz = 2*sizeof(double);
    break;
#endif
  }
  SYSCALLDEF(port =
	     MAKINUM(fread(CHARS(v),(sizet)sz,(sizet)len,STREAM(port))););
  if (TYP7(v)==tc7_bvect) port = MAKINUM(INUM(port)*LONG_BIT);
  return port;
}

static char s_uve_wr[]="uniform-vector-write";
SCM uve_write(v,port)
SCM v,port;
{
  long sz, len;
  if UNBNDP(port) port = cur_outp;
  else ASSERT(NIMP(port) && OPOUTPORTP(port),port,ARG2,s_uve_wr);
  ASRTGO(NIMP(v),badarg1);
  len = LENGTH(v);
  switch TYP7(v) {
  default: badarg1: wta(v,(char *)ARG1,s_uve_wr);
  case tc7_string:
    sz = sizeof(char);
    break;
  case tc7_bvect:
    len = (len+LONG_BIT-1)/LONG_BIT;
  case tc7_uvect: 
  case tc7_ivect:
    sz = sizeof(long);
    break;
#ifdef FLOATS
#ifdef SINGLES
  case tc7_fvect:
    sz = sizeof(float);
    break;
#endif
  case tc7_dvect:
    sz = sizeof(double);
    break;
  case tc7_cvect:
    sz = 2*sizeof(double);
    break;
#endif
  }
  SYSCALLDEF(port =
	     MAKINUM(fwrite(CHARS(v),(sizet)sz,(sizet)len,STREAM(port))););
  if (TYP7(v)==tc7_bvect) port = MAKINUM(INUM(port)*LONG_BIT);
  return port;
}

static char cnt_tab[16]={0,1,1,2,1,2,2,3,1,2,2,3,2,3,3,4};
static char s_count[]="bit-count";
SCM lcount(item, seq)
     SCM item, seq;
{
  long i;
  register unsigned long cnt=0, w;
  ASSERT(NIMP(seq),seq,ARG2,s_count);
  switch TYP7(seq) {
  default: wta(seq,(char *)ARG2,s_count);
  case tc7_bvect:
    if (0==LENGTH(seq)) return INUM0;
    i=(LENGTH(seq)-1)/LONG_BIT;
    w = VELTS(seq)[i];
    if (BOOL_F == item) w = ~w;
    w <<= LONG_BIT-1-((LENGTH(seq)-1)%LONG_BIT);
    while (!0) {
      for(;w;w >>= 4) cnt += cnt_tab[w & 0x0f];
      if (0 == i--) return MAKINUM(cnt);
      w = VELTS(seq)[i];
      if (BOOL_F == item) w = ~w;
    }
  }
}
static char s_uve_pos[]="bit-position";
SCM position(item,v,k)
SCM item,v,k;
{
  long i, lenw, xbits;
  register unsigned long w, pos = INUM(k);
  ASSERT(NIMP(v),v,ARG2,s_uve_pos);
  ASSERT(INUMP(k),k,ARG3,s_uve_pos);
  ASSERT((INUM(k) < LENGTH(v)) && (INUM(k) >= 0),
	 k,OUTOFRANGE,s_uve_pos);
  switch TYP7(v) {
  default: wta(v,(char *)ARG2,s_uve_pos);
  case tc7_bvect:
    if (0==LENGTH(v)) return MAKINUM(-1);
    lenw = (LENGTH(v)-1)/LONG_BIT; /* watch for part words */
    i = pos/LONG_BIT;
    w = VELTS(v)[i];
    if (BOOL_F == item) w = ~w;
    xbits = (pos%LONG_BIT);
    pos -= xbits;
    w = ((w >> xbits) << xbits);
    xbits = LONG_BIT-1-(LENGTH(v)-1)%LONG_BIT;
    while (!0) {
      if (w && (i == lenw))
	w = ((w << xbits) >> xbits);
      if (w) while (w) switch (w & 0x0f)
	{
	default: return MAKINUM(pos);
	case 2: case 6: case 10: case 14: return MAKINUM(pos+1);
	case 4: case 12: return MAKINUM(pos+2);
	case 8: return MAKINUM(pos+3);
	case 0: pos += 4; w >>= 4;
	}
      if (++i > lenw) break;
      pos += LONG_BIT;
      w = VELTS(v)[i];
      if (BOOL_F == item) w = ~w;
    }
    return MAKINUM(-1);
  }
}

static char s_bit_set[]="bit-set*!";
SCM bit_set(v,kv,obj)
SCM v,kv,obj;
{
  register long i, k, vlen;
  ASRTGO(NIMP(v),badarg1);
  ASRTGO(NIMP(kv),badarg2);
  switch TYP7(kv) {
    default: badarg2: wta(kv,(char *)ARG2,s_bit_set);
    case tc7_uvect:
      switch TYP7(v) {
	default: badarg1: wta(v,(char *)ARG1,s_bit_set);
	case tc7_bvect:
	  vlen = LENGTH(v);
	  if (BOOL_F == obj) for (i=LENGTH(kv);i;) {
	    k = VELTS(kv)[--i];
	    ASSERT((k < vlen), MAKINUM(k),OUTOFRANGE,s_bit_set);
	    VELTS(v)[k/LONG_BIT] &= ~(1L<<(k%LONG_BIT));
	  }
          else if (BOOL_T == obj) for (i=LENGTH(kv); i;) {
	    k = VELTS(kv)[--i];
            ASSERT((k < vlen), MAKINUM(k),OUTOFRANGE,s_bit_set);
            VELTS(v)[k/LONG_BIT] |= (1L<<(k%LONG_BIT));
          }
	  else wta(obj,(char *)ARG3,s_bit_set);
	}
      break;
    case tc7_bvect:
      ASRTGO(TYP7(v)==tc7_bvect && LENGTH(v) == LENGTH(kv),badarg1);
      if (BOOL_F == obj)
	for (k=(LENGTH(v)+LONG_BIT-1)/LONG_BIT;k--;)
	  VELTS(v)[k] &= ~(VELTS(kv)[k]);
      else if (BOOL_T == obj)
	for (k=(LENGTH(v)+LONG_BIT-1)/LONG_BIT;k--;)
	  VELTS(v)[k] |= VELTS(kv)[k];
      else goto badarg2;
      break;
    }
  return UNSPECIFIED;
}

static char s_bit_inv[]="bit-invert!";
SCM bit_inv(v)
SCM v;
{
  register long k;
  ASRTGO(NIMP(v),badarg1);
  k = LENGTH(v);
  switch TYP7(v) {
  default: badarg1: wta(v,(char *)ARG1,s_bit_inv);
  case tc7_bvect:
    for (k=(k+LONG_BIT-1)/LONG_BIT;k--;)
      VELTS(v)[k] = ~VELTS(v)[k];
  }
  return UNSPECIFIED;
}

char s_resizuve[]="vector-set-length!";
SCM resizuve(vect, len)
     SCM vect, len;
{
  char *tmp;
  long l = INUM(len), sz;
  ASRTGO(NIMP(vect),badarg1);
  switch TYP7(vect) {
  default: badarg1: wta(vect,(char *)ARG1,s_resizuve);
  case tc7_string:
    ASRTGO(vect != nullstr,badarg1);
    sz = sizeof(char);
    l++;
    break;
  case tc7_vector:
    ASRTGO(vect != nullvect,badarg1);
    sz = sizeof(SCM);
    break;
  case tc7_bvect:
    l = (l+LONG_BIT-1)/LONG_BIT;
  case tc7_uvect:
  case tc7_ivect:
    sz = sizeof(long);
    break;
#ifdef FLOATS
#ifdef SINGLES
  case tc7_fvect:
    sz = sizeof(float);
    break;
#endif
  case tc7_dvect:
    sz = sizeof(double);
    break;
  case tc7_cvect:
    sz = 2*sizeof(double);
    break;
#endif
  }
  ASSERT(INUMP(len),len,ARG2,s_resizuve);
  if (!l) l = 1L;
  DEFER_INTS;
  SYSCALL(tmp = (char *)realloc((char *)CHARS(vect),l * sz););
  if (tmp) {
    SETCHARS(vect,tmp);
    if VECTORP(vect) while(l > INUM(len)) VELTS(vect)[--l]=UNSPECIFIED;
    else if STRINGP(vect) CHARS(vect)[l-1]=0;
    SETLENGTH(vect,INUM(len),TYP7(vect));
  }
  ALLOW_INTS;
  if (!tmp) wta(len,(char *)NALLOC,s_resizuve);
  return vect;
}

static iproc lsubr2s[]={
	{s_make_uve, make_uve},
	{s_uve_ref, uve_ref},
	{s_uve_fill, uve_fill},
	{s_resizuve,resizuve},
	{0,0}};

void init_unif()
{
  init_iprocs(lsubr2s, tc7_lsubr_2);
  make_subr(s_uve_len, tc7_subr_1, uve_len);
  make_subr(s_uve_set, tc7_subr_3, uve_set);
  make_subr(s_uve_rd, tc7_subr_2o, uve_read);
  make_subr(s_uve_wr, tc7_subr_2o, uve_write);

  make_subr(s_count, tc7_subr_2, lcount);
  make_subr(s_uve_pos, tc7_subr_3, position);
  make_subr(s_bit_set, tc7_subr_3, bit_set);
  make_subr(s_bit_inv, tc7_subr_1, bit_inv);
}
