/*
 * hbytes - hex-stringrep efficient byteblocks for Tcl
 * Copyright 2006-2012 Ian Jackson
 *
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License as
 * published by the Free Software Foundation; either version 2 of the
 * License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this library; if not, see <http://www.gnu.org/licenses/>.
 */

#include "chiark_tcl_hbytes.h"

/* nice simple functions */

int cht_do_ulong_int2ul(ClientData cd, Tcl_Interp *ip, int v,
		    uint32_t *result) {
  if (v<0) return cht_staticerr(ip,"cannot convert"
      " -ve integer to ulong","ULONG VALUE NEGATIVE");
  *result= v;
  return TCL_OK;
}
  
int cht_do_ulong_add(ClientData cd, Tcl_Interp *ip,
		 uint32_t a, uint32_t b, uint32_t *result) {
  *result= a + b;
  return TCL_OK;
}
  
int cht_do_ulong_multiply(ClientData cd, Tcl_Interp *ip,
		      uint32_t a, uint32_t b, uint32_t *result) {
  *result= a * b;
  return TCL_OK;
}
  
int cht_do_ulong_subtract(ClientData cd, Tcl_Interp *ip,
		      uint32_t a, uint32_t b, uint32_t *result) {
  *result= a - b;
  return TCL_OK;
}
  
int cht_do_ulong_compare(ClientData cd, Tcl_Interp *ip,
		     uint32_t a, uint32_t b, int *result) {
  *result=
    a == b ? 0 :
    a < b ? -1 : 1;
  return TCL_OK;
}

int cht_do_ulong_ul2int(ClientData cd, Tcl_Interp *ip,
		    uint32_t v, int *result) {
  if (v>INT_MAX) return
		   cht_staticerr(ip,"ulong too large"
				 " to fit in an int", "ULONG VALUE OVERFLOW");
  *result= v;
  return TCL_OK;
}

int cht_do_ulong_mask(ClientData cd, Tcl_Interp *ip,
		  uint32_t a, uint32_t b, uint32_t *result) {
  *result= a & b;
  return TCL_OK;
}
  
int cht_do_ulong_shift(ClientData cd, Tcl_Interp *ip, int right,
		   uint32_t v, int bits, uint32_t *result) {
  if (bits < 0) { bits= -bits; right= !right; }
  if (bits > 32) return cht_staticerr(ip,"shift out of range (32) bits",
				      "ULONG BITCOUNT OVERRUN");
  *result= (bits==32 ? 0 :
	    right ? v >> bits : v << bits);
  return TCL_OK;
}

/* bitfields */

typedef struct {
  const char *name;
  int want_arg;
  int (*reader_writer[2])(Tcl_Interp *ip, uint32_t *value_io,
			  int *ok_io, Tcl_Obj *arg);
} BitFieldType;

static int bf_zero_read(Tcl_Interp *ip, uint32_t *value_io,
			int *ok_io, Tcl_Obj *arg) {
  if (*value_io) *ok_io= 0;
  return TCL_OK;
}

static int bf_zero_write(Tcl_Interp *ip, uint32_t *value_io,
			 int *ok_io, Tcl_Obj *arg) {
  *value_io= 0;
  return TCL_OK;
}

static int bf_ignore(Tcl_Interp *ip, uint32_t *value_io,
		     int *ok_io, Tcl_Obj *arg) {
  return TCL_OK;
}

static int bf_fixed_read(Tcl_Interp *ip, uint32_t *value_io,
			 int *ok_io, Tcl_Obj *arg) {
  uint32_t ul;
  int rc;
  
  rc= cht_pat_ulong(ip, arg, &ul);  if (rc) return rc;
  if (*value_io != ul) *ok_io= 0;
  return TCL_OK;
}

static int bf_ulong_write(Tcl_Interp *ip, uint32_t *value_io,
			  int *ok_io, Tcl_Obj *arg) {
  uint32_t ul;
  int rc;
  
  rc= cht_pat_ulong(ip, arg, &ul);  if (rc) return rc;
  *value_io= ul;
  return TCL_OK;
}

static int bf_var_read(Tcl_Interp *ip, Tcl_Obj *varname, Tcl_Obj *val) {
  Tcl_Obj *rp;
  rp= Tcl_ObjSetVar2(ip,varname,0,val,TCL_LEAVE_ERR_MSG);
  if (!rp) return TCL_ERROR;
  return TCL_OK;
}

static int bf_ulong_read(Tcl_Interp *ip, uint32_t *value_io,
			 int *ok_io, Tcl_Obj *arg) {
  return bf_var_read(ip,arg, cht_ret_ulong(ip,*value_io));
}

static int bf_uint_write(Tcl_Interp *ip, uint32_t *value_io,
			 int *ok_io, Tcl_Obj *arg) {
  int rc, v;
  rc= cht_pat_int(ip, arg, &v);  if (rc) return rc;
  if (v<0) return cht_staticerr(ip,"value for bitfield is -ve",
				"ULONG VALUE NEGATIVE");
  *value_io= v;
  return TCL_OK;
}

static int bf_uint_read(Tcl_Interp *ip, uint32_t *value_io,
			int *ok_io, Tcl_Obj *arg) {
  if (*value_io > INT_MAX)
    return cht_staticerr(ip,"value from bitfield"
			 " exceeds INT_MAX","ULONG VALUE OVERFLOW");
  return bf_var_read(ip,arg, cht_ret_int(ip,*value_io));
}

#define BFT(t,a) { #t, a, { bf_read_##t, bf_write_##t } }
static const BitFieldType bitfieldtypes[]= {
  { "zero",   0, { bf_zero_read,  bf_zero_write  } },
  { "ignore", 0, { bf_ignore,     bf_ignore      } },
  { "fixed",  1, { bf_fixed_read, bf_ulong_write } },
  { "ulong",  1, { bf_ulong_read, bf_ulong_write } },
  { "uint",   1, { bf_uint_read,  bf_uint_write  } },
  { 0 }
};

static int do_bitfields(Tcl_Interp *ip, int writing, int *ok_r,
			uint32_t *value_io,
			int objc, Tcl_Obj *const *objv) {
  const BitFieldType *ftype;
  Tcl_Obj *arg;
  int sz, pos, rc;
  uint32_t value, sz_mask, this_mask, this_field;
  
  pos= 32;
  value= *value_io;
  *ok_r= 1;

  while (--objc) {
    rc= Tcl_GetIntFromObj(ip,*++objv,&sz);  if (rc) return rc;
    if (!--objc)
      return cht_staticerr(ip,"wrong # args: missing bitfield type",0);

    if (sz<0)
      return cht_staticerr(ip,"bitfield size is -ve",
			   "ULONG BITCOUNT NEGATIVE");
    if (sz>pos)
      return cht_staticerr(ip,"total size of bitfields >32",
			   "ULONG BITCOUNT OVERRUN");

    pos -= sz;

    sz_mask= ~(~0UL << sz);
    this_mask= (sz_mask << pos);
    this_field= (value & this_mask) >> pos;
    
    ftype= enum_lookup_cached(ip,*++objv,bitfieldtypes,"bitfield type");
    if (!ftype) return TCL_ERROR;

    if (ftype->want_arg) {
      if (!--objc)
	return cht_staticerr(ip,"wrong # args: missing arg for bitfield",0);
      arg= *++objv;
    } else {
      arg= 0;
    }
    rc= ftype->reader_writer[writing](ip, &this_field, ok_r, arg);
    if (rc) return rc;

    if (!*ok_r) return TCL_OK;

    if (this_field & ~sz_mask)
      return cht_staticerr(ip,"bitfield value has more bits than bitfield",
		       "ULONG VALUE OVERFLOW");
    
    value &= ~this_mask;
    value |= (this_field << pos);
  }

  if (pos != 0) return
    cht_staticerr(ip,"bitfield sizes add up to <32","ULONG BITCOUNT UNDERRUN");

  *value_io= value;
  return TCL_OK;
}

int cht_do_ulong_bitfields2ul(ClientData cd, Tcl_Interp *ip,
			  uint32_t base,
			  int objc, Tcl_Obj *const *objv,
			  uint32_t *result) {
  int ok, rc;
  
  *result= base;
  rc= do_bitfields(ip,1,&ok,result,objc,objv);
  assert(ok);
  return rc;
}

int cht_do_ulong_ul2bitfields(ClientData cd, Tcl_Interp *ip,
			  uint32_t value,
			  int objc, Tcl_Obj *const *objv,
			  int *result) {
  return do_bitfields(ip,0,result,&value,objc,objv);
}

/* Arg parsing */

int cht_pat_ulong(Tcl_Interp *ip, Tcl_Obj *o, uint32_t *val) {
  int rc;
  
  rc= Tcl_ConvertToType(ip,o,&cht_ulong_type);
  if (rc) return rc;
  *val= *(const uint32_t*)&o->internalRep.longValue;
  return TCL_OK;
}

Tcl_Obj *cht_ret_ulong(Tcl_Interp *ip, uint32_t val) {
  Tcl_Obj *o;

  o= Tcl_NewObj();
  Tcl_InvalidateStringRep(o);
  *(uint32_t*)&o->internalRep.longValue= val;
  o->typePtr= &cht_ulong_type;
  return o;
}

/* Tcl ulong type */

static void ulong_t_free(Tcl_Obj *o) { }

static void ulong_t_dup(Tcl_Obj *src, Tcl_Obj *dup) {
  dup->internalRep= src->internalRep;
  dup->typePtr= &cht_ulong_type;
}

static void ulong_t_ustr(Tcl_Obj *o) {
  uint32_t val;
  char buf[9];

  val= *(const uint32_t*)&o->internalRep.longValue;
  snprintf(buf,sizeof(buf), "%08lx", (unsigned long)val);
  cht_obj_updatestr_vstringls(o, buf, sizeof(buf)-1, (char*)0);
}

static int ulong_t_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
  char *str, *ep;
  uint32_t ul;

  if (o->typePtr == &cht_hbytes_type) {
    int l;

    l= cht_hb_len(OBJ_HBYTES(o));
    if (l > 4) return cht_staticerr(ip,"hbytes as ulong with length >4",
				    "HBYTES LENGTH OVERRUN");
    ul= 0;
    memcpy((Byte*)&ul + 4 - l, cht_hb_data(OBJ_HBYTES(o)), l);
    ul= htonl(ul);

  } else {

    str= Tcl_GetString(o);
    errno=0;
    if (str[0]=='0' && str[1]=='b' && str[2]) {
      ul= strtoul(str+2,&ep,2);
    } else if (str[0]=='0' && str[1]=='d' && str[2]) {
      ul= strtoul(str+2,&ep,10);
    } else {
      ul= strtoul(str,&ep,16);
    }
    if (*ep || errno) return cht_staticerr(ip, "bad unsigned long value", 0);

  }

  cht_objfreeir(o);
  *(uint32_t*)&o->internalRep.longValue= ul;
  o->typePtr= &cht_ulong_type;
  return TCL_OK;
}

Tcl_ObjType cht_ulong_type = {
  "ulong-nearly",
  ulong_t_free, ulong_t_dup, ulong_t_ustr, ulong_t_sfa
};
