chiark / gitweb /
2d73e3d16d42667d26d98df46f3e35005cd8fc3a
[chiark-tcl.git] / base / idtable.c
1 /*
2  */
3
4 #include "chiark-tcl.h"
5 #include "tables.h"
6
7 /* Arg parsing */
8
9 typedef struct {
10   const IdDataSpec *idds;
11   int n;
12   void **a;
13 } IdDataAssocData;
14
15 typedef struct {
16   Tcl_Interp *interp;
17   IdDataAssocData *assoc;
18   int ix;
19 } IdDataValue;
20
21 static void assoc_del(ClientData assoc_cd, Tcl_Interp *ip) {
22   IdDataAssocData *assoc;
23   int ix;
24   void **p, *v;
25
26   assoc= assoc_cd;
27   for (ix=0, p=assoc->a; ix<assoc->n; ix++, p++) {
28     v= *p;
29     if (!v) continue;
30     assert(*(int*)v == ix);
31     *(int*)v= -1;
32     assoc->idds->destroyitem(ip,v);
33     *p= 0;
34   }
35   TFREE(assoc->a);
36   TFREE(assoc);
37 }
38
39 static void setobjdataid(Tcl_Interp *interp, Tcl_Obj *o,
40                          int ix, const IdDataSpec *idds) {
41   IdDataValue *dv;
42   IdDataAssocData *assoc;
43
44   assoc= Tcl_GetAssocData(interp, (char*)idds->assockey, 0);
45   if (!assoc) {
46     assoc= TALLOC(sizeof(*assoc));
47     assoc->idds= idds;
48     assoc->n= 0;
49     assoc->a= 0;
50     Tcl_SetAssocData(interp, (char*)idds->assockey, assoc_del, assoc);
51   }
52   
53   dv= TALLOC(sizeof(*dv));
54   dv->interp= interp;
55   dv->assoc= assoc;
56   dv->ix= ix;
57   
58   o->typePtr= &cht_tabledataid_nearlytype;
59   o->internalRep.otherValuePtr= dv;
60 }
61
62 int cht_tabledataid_parse(Tcl_Interp *ip, Tcl_Obj *o, const IdDataSpec *idds) {
63   int l;
64   unsigned long ul;
65   IdDataValue *dv;
66   IdDataAssocData *assoc;
67   char *ep, *str;
68
69   if (o->typePtr != &cht_tabledataid_nearlytype) goto convert;
70
71   dv= o->internalRep.otherValuePtr;
72   if (dv->interp != ip) goto convert;
73   assoc= dv->assoc;
74   if (dv->assoc->idds != idds) goto convert;
75
76   return TCL_OK;
77
78 convert:
79   l= strlen(idds->valprefix);
80   str= Tcl_GetStringFromObj(o,0);
81   if (memcmp(str,idds->valprefix,l))
82     return cht_staticerr(ip,"bad id (wrong prefix)",0);
83
84   errno=0; ul=strtoul(str+l,&ep,10);
85   if (errno || *ep) return cht_staticerr(ip,"bad id number",0);
86   if (ul > INT_MAX) return cht_staticerr(ip,"out of range id number",0);
87
88   cht_objfreeir(o);
89   setobjdataid(ip,o,ul,idds);
90   return TCL_OK;
91 }
92
93 int cht_pat_iddata(Tcl_Interp *ip, Tcl_Obj *o, void **rv, const IdDataSpec *idds) {
94   int rc, ix;
95   IdDataValue *dv;
96   IdDataAssocData *assoc;
97   void *r;
98   
99   rc= cht_tabledataid_parse(ip,o,idds);
100   if (rc) return rc;
101
102   dv= o->internalRep.otherValuePtr;
103   ix= dv->ix;
104   assoc= dv->assoc;
105
106   if (ix >= assoc->n || !(r= assoc->a[ix]))
107     return cht_staticerr(ip,"id not in use",0);
108
109   assert(*(int*)r == ix);
110
111   *rv= r;
112   return TCL_OK;
113 }
114
115 Tcl_Obj *cht_ret_iddata(Tcl_Interp *ip, void *val, const IdDataSpec *idds) {
116   /* Command procedure implementation may set val->ix,
117    * ie *(int*)val, to -1, to mean it's a new struct.  Otherwise
118    * it had better be an old one !
119    */
120   Tcl_Obj *o;
121   IdDataValue *dv;
122   IdDataAssocData *assoc;
123   int ix;
124
125   o= Tcl_NewObj();
126   setobjdataid(ip,o,0,idds);
127   dv= o->internalRep.otherValuePtr;
128   assoc= dv->assoc;
129
130   ix= *(int*)val;
131   if (ix==-1) {
132     for (ix=0; ix<assoc->n && assoc->a[ix]; ix++);
133     if (ix>=assoc->n) {
134       assoc->n += 2;
135       assoc->n *= 2;
136       assoc->a= TREALLOC(assoc->a, assoc->n*sizeof(*assoc->a));
137       while (ix<assoc->n) assoc->a[ix++]=0;
138       ix--;
139     }
140     assoc->a[ix]= val;
141     *(int*)val= ix;
142   } else {
143     assert(val == assoc->a[ix]);
144   }
145   dv->ix= ix;
146   Tcl_InvalidateStringRep(o);
147   return o;
148 }
149
150 void cht_tabledataid_disposing(Tcl_Interp *ip, void *val, const IdDataSpec *idds) {
151   IdDataAssocData *assoc;
152   int ix;
153
154   ix= *(int*)val;
155   if (ix==-1) return;
156
157   assoc= Tcl_GetAssocData(ip, (char*)idds->assockey, 0);
158   assert(assoc->a[ix] == val);
159   assoc->a[ix]= 0;
160   *(int*)val= -1;
161 }
162
163 static int tabledataid_nt_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
164   abort();
165 }
166
167 static void tabledataid_nt_free(Tcl_Obj *o) {
168   TFREE(o->internalRep.otherValuePtr);
169   o->internalRep.otherValuePtr= 0;
170 }
171
172 static void tabledataid_nt_dup(Tcl_Obj *src, Tcl_Obj *dup) {
173   IdDataValue *sv, *dv;
174
175   sv= src->internalRep.otherValuePtr;
176   dv= TALLOC(sizeof(*dv));
177   *dv= *sv;
178   dup->typePtr= &cht_tabledataid_nearlytype;
179   dup->internalRep.otherValuePtr= dv;
180 }
181
182 static void tabledataid_nt_ustr(Tcl_Obj *o) {
183   const IdDataValue *dv;
184   const IdDataAssocData *assoc;
185   const IdDataSpec *idds;
186   char buf[75];
187
188   dv= o->internalRep.otherValuePtr;
189   assoc= dv->assoc;
190   idds= assoc->idds;
191
192   snprintf(buf,sizeof(buf), "%d", dv->ix);
193   cht_obj_updatestr_vstringls(o,
194                           idds->valprefix, strlen(idds->valprefix),
195                           buf, strlen(buf),
196                           (char*)0);
197 }
198
199 Tcl_ObjType cht_tabledataid_nearlytype = {
200   "tabledataid",
201   tabledataid_nt_free, tabledataid_nt_dup,
202   tabledataid_nt_ustr, tabledataid_nt_sfa
203 };