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