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