chiark / gitweb /
hbytes and crypto compile now
[chiark-tcl.git] / hbytes / ulongs.c
1 /*
2  */
3
4 #include "chiark_tcl_hbytes.h"
5
6 /* nice simple functions */
7
8 int cht_do_ulong_int2ul(ClientData cd, Tcl_Interp *ip, int v,
9                     uint32_t *result) {
10   if (v<0) return cht_staticerr(ip,"cannot convert"
11       " -ve integer to ulong","ULONG VALUE NEGATIVE");
12   *result= v;
13   return TCL_OK;
14 }
15   
16 int cht_do_ulong_add(ClientData cd, Tcl_Interp *ip,
17                  uint32_t a, uint32_t b, uint32_t *result) {
18   *result= a + b;
19   return TCL_OK;
20 }
21   
22 int cht_do_ulong_multiply(ClientData cd, Tcl_Interp *ip,
23                       uint32_t a, uint32_t b, uint32_t *result) {
24   *result= a * b;
25   return TCL_OK;
26 }
27   
28 int cht_do_ulong_subtract(ClientData cd, Tcl_Interp *ip,
29                       uint32_t a, uint32_t b, uint32_t *result) {
30   *result= a - b;
31   return TCL_OK;
32 }
33   
34 int cht_do_ulong_compare(ClientData cd, Tcl_Interp *ip,
35                      uint32_t a, uint32_t b, int *result) {
36   *result=
37     a == b ? 0 :
38     a < b ? -1 : 1;
39   return TCL_OK;
40 }
41
42 int cht_do_ulong_ul2int(ClientData cd, Tcl_Interp *ip,
43                     uint32_t v, int *result) {
44   if (v>INT_MAX) return
45                    cht_staticerr(ip,"ulong too large"
46                                  " to fit in an int", "ULONG VALUE OVERFLOW");
47   *result= v;
48   return TCL_OK;
49 }
50
51 int cht_do_ulong_mask(ClientData cd, Tcl_Interp *ip,
52                   uint32_t a, uint32_t b, uint32_t *result) {
53   *result= a & b;
54   return TCL_OK;
55 }
56   
57 int cht_do_ulong_shift(ClientData cd, Tcl_Interp *ip, int right,
58                    uint32_t v, int bits, uint32_t *result) {
59   if (bits < 0) { bits= -bits; right= !right; }
60   if (bits > 32) return cht_staticerr(ip,"shift out of range (32) bits",
61                                       "ULONG BITCOUNT OVERRUN");
62   *result= (bits==32 ? 0 :
63             right ? v >> bits : v << bits);
64   return TCL_OK;
65 }
66
67 /* bitfields */
68
69 typedef struct {
70   const char *name;
71   int want_arg;
72   int (*reader_writer[2])(Tcl_Interp *ip, uint32_t *value_io,
73                           int *ok_io, Tcl_Obj *arg);
74 } BitFieldType;
75
76 static int bf_zero_read(Tcl_Interp *ip, uint32_t *value_io,
77                         int *ok_io, Tcl_Obj *arg) {
78   if (*value_io) *ok_io= 0;
79   return TCL_OK;
80 }
81
82 static int bf_zero_write(Tcl_Interp *ip, uint32_t *value_io,
83                          int *ok_io, Tcl_Obj *arg) {
84   *value_io= 0;
85   return TCL_OK;
86 }
87
88 static int bf_ignore(Tcl_Interp *ip, uint32_t *value_io,
89                      int *ok_io, Tcl_Obj *arg) {
90   return TCL_OK;
91 }
92
93 static int bf_fixed_read(Tcl_Interp *ip, uint32_t *value_io,
94                          int *ok_io, Tcl_Obj *arg) {
95   uint32_t ul;
96   int rc;
97   
98   rc= cht_pat_ulong(ip, arg, &ul);  if (rc) return rc;
99   if (*value_io != ul) *ok_io= 0;
100   return TCL_OK;
101 }
102
103 static int bf_ulong_write(Tcl_Interp *ip, uint32_t *value_io,
104                           int *ok_io, Tcl_Obj *arg) {
105   uint32_t ul;
106   int rc;
107   
108   rc= cht_pat_ulong(ip, arg, &ul);  if (rc) return rc;
109   *value_io= ul;
110   return TCL_OK;
111 }
112
113 static int bf_var_read(Tcl_Interp *ip, Tcl_Obj *varname, Tcl_Obj *val) {
114   Tcl_Obj *rp;
115   rp= Tcl_ObjSetVar2(ip,varname,0,val,TCL_LEAVE_ERR_MSG);
116   if (!rp) return TCL_ERROR;
117   return TCL_OK;
118 }
119
120 static int bf_ulong_read(Tcl_Interp *ip, uint32_t *value_io,
121                          int *ok_io, Tcl_Obj *arg) {
122   return bf_var_read(ip,arg, cht_ret_ulong(ip,*value_io));
123 }
124
125 static int bf_uint_write(Tcl_Interp *ip, uint32_t *value_io,
126                          int *ok_io, Tcl_Obj *arg) {
127   int rc, v;
128   rc= cht_pat_int(ip, arg, &v);  if (rc) return rc;
129   if (v<0) return cht_staticerr(ip,"value for bitfield is -ve",
130                                 "ULONG VALUE NEGATIVE");
131   *value_io= v;
132   return TCL_OK;
133 }
134
135 static int bf_uint_read(Tcl_Interp *ip, uint32_t *value_io,
136                         int *ok_io, Tcl_Obj *arg) {
137   if (*value_io > INT_MAX)
138     return cht_staticerr(ip,"value from bitfield"
139                          " exceeds INT_MAX","ULONG VALUE OVERFLOW");
140   return bf_var_read(ip,arg, cht_ret_int(ip,*value_io));
141 }
142
143 #define BFT(t,a) { #t, a, { bf_read_##t, bf_write_##t } }
144 static const BitFieldType bitfieldtypes[]= {
145   { "zero",   0, { bf_zero_read,  bf_zero_write  } },
146   { "ignore", 0, { bf_ignore,     bf_ignore      } },
147   { "fixed",  1, { bf_fixed_read, bf_ulong_write } },
148   { "ulong",  1, { bf_ulong_read, bf_ulong_write } },
149   { "uint",   1, { bf_uint_read,  bf_uint_write  } },
150   { 0 }
151 };
152
153 static int do_bitfields(Tcl_Interp *ip, int writing, int *ok_r,
154                         uint32_t *value_io,
155                         int objc, Tcl_Obj *const *objv) {
156   const BitFieldType *ftype;
157   Tcl_Obj *arg;
158   int sz, pos, rc;
159   uint32_t value, sz_mask, this_mask, this_field;
160   
161   pos= 32;
162   value= *value_io;
163   *ok_r= 1;
164
165   while (--objc) {
166     rc= Tcl_GetIntFromObj(ip,*++objv,&sz);  if (rc) return rc;
167     if (!--objc)
168       return cht_staticerr(ip,"wrong # args: missing bitfield type",0);
169
170     if (sz<0)
171       return cht_staticerr(ip,"bitfield size is -ve",
172                            "ULONG BITCOUNT NEGATIVE");
173     if (sz>pos)
174       return cht_staticerr(ip,"total size of bitfields >32",
175                            "ULONG BITCOUNT OVERRUN");
176
177     pos -= sz;
178
179     sz_mask= ~(~0UL << sz);
180     this_mask= (sz_mask << pos);
181     this_field= (value & this_mask) >> pos;
182     
183     ftype= enum_lookup_cached(ip,*++objv,bitfieldtypes,"bitfield type");
184     if (!ftype) return TCL_ERROR;
185
186     if (ftype->want_arg) {
187       if (!--objc)
188         return cht_staticerr(ip,"wrong # args: missing arg for bitfield",0);
189       arg= *++objv;
190     } else {
191       arg= 0;
192     }
193     rc= ftype->reader_writer[writing](ip, &this_field, ok_r, arg);
194     if (rc) return rc;
195
196     if (!*ok_r) return TCL_OK;
197
198     if (this_field & ~sz_mask)
199       return cht_staticerr(ip,"bitfield value has more bits than bitfield",
200                        "ULONG VALUE OVERFLOW");
201     
202     value &= ~this_mask;
203     value |= (this_field << pos);
204   }
205
206   if (pos != 0) return
207     cht_staticerr(ip,"bitfield sizes add up to <32","ULONG BITCOUNT UNDERRUN");
208
209   *value_io= value;
210   return TCL_OK;
211 }
212
213 int cht_do_ulong_bitfields2ul(ClientData cd, Tcl_Interp *ip,
214                           uint32_t base,
215                           int objc, Tcl_Obj *const *objv,
216                           uint32_t *result) {
217   int ok, rc;
218   
219   *result= base;
220   rc= do_bitfields(ip,1,&ok,result,objc,objv);
221   assert(ok);
222   return rc;
223 }
224
225 int cht_do_ulong_ul2bitfields(ClientData cd, Tcl_Interp *ip,
226                           uint32_t value,
227                           int objc, Tcl_Obj *const *objv,
228                           int *result) {
229   return do_bitfields(ip,0,result,&value,objc,objv);
230 }
231
232 /* Arg parsing */
233
234 int cht_pat_ulong(Tcl_Interp *ip, Tcl_Obj *o, uint32_t *val) {
235   int rc;
236   
237   rc= Tcl_ConvertToType(ip,o,&cht_ulong_type);
238   if (rc) return rc;
239   *val= *(const uint32_t*)&o->internalRep.longValue;
240   return TCL_OK;
241 }
242
243 Tcl_Obj *cht_ret_ulong(Tcl_Interp *ip, uint32_t val) {
244   Tcl_Obj *o;
245
246   o= Tcl_NewObj();
247   Tcl_InvalidateStringRep(o);
248   *(uint32_t*)&o->internalRep.longValue= val;
249   o->typePtr= &cht_ulong_type;
250   return o;
251 }
252
253 /* Tcl ulong type */
254
255 static void ulong_t_free(Tcl_Obj *o) { }
256
257 static void ulong_t_dup(Tcl_Obj *src, Tcl_Obj *dup) {
258   dup->internalRep= src->internalRep;
259   dup->typePtr= &cht_ulong_type;
260 }
261
262 static void ulong_t_ustr(Tcl_Obj *o) {
263   uint32_t val;
264   char buf[9];
265
266   val= *(const uint32_t*)&o->internalRep.longValue;
267
268   assert(val <= 0xffffffffUL);
269   snprintf(buf,sizeof(buf), "%08lx", (unsigned long)val);
270
271   cht_obj_updatestr_vstringls(o, buf, sizeof(buf)-1, (char*)0);
272 }
273
274 static int ulong_t_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
275   char *str, *ep;
276   uint32_t ul;
277
278   if (o->typePtr == &cht_hbytes_type) {
279     int l;
280
281     l= cht_hb_len(OBJ_HBYTES(o));
282     if (l > 4) return cht_staticerr(ip,"hbytes as ulong with length >4",
283                                     "HBYTES LENGTH OVERRUN");
284     ul= 0;
285     memcpy((Byte*)&ul + 4 - l, cht_hb_data(OBJ_HBYTES(o)), l);
286     ul= htonl(ul);
287
288   } else {
289
290     str= Tcl_GetString(o);
291     errno=0;
292     if (str[0]=='0' && str[1]=='b' && str[2]) {
293       ul= strtoul(str+2,&ep,2);
294     } else if (str[0]=='0' && str[1]=='d' && str[2]) {
295       ul= strtoul(str+2,&ep,10);
296     } else {
297       ul= strtoul(str,&ep,16);
298     }
299     if (*ep || errno) return cht_staticerr(ip, "bad unsigned long value", 0);
300
301   }
302
303   cht_objfreeir(o);
304   *(uint32_t*)&o->internalRep.longValue= ul;
305   o->typePtr= &cht_ulong_type;
306   return TCL_OK;
307 }
308
309 Tcl_ObjType cht_ulong_type = {
310   "ulong-nearly",
311   ulong_t_free, ulong_t_dup, ulong_t_ustr, ulong_t_sfa
312 };