chiark / gitweb /
c23906e5d53b7fdcdea6d35ca3a1d8fcaf34f00c
[chiark-tcl.git] / base / idtable.c
1 /*
2  * base code for various Tcl extensions
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, 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       assert(assoc->n < INT_MAX/4);
151       assoc->n += 2;
152       assoc->n *= 2;
153       assoc->a= TREALLOC(assoc->a, assoc->n*sizeof(*assoc->a));
154       while (ix<assoc->n) assoc->a[ix++]=0;
155       ix--;
156     }
157     assoc->a[ix]= val;
158     *(int*)val= ix;
159   } else {
160     assert(val == assoc->a[ix]);
161   }
162   dv->ix= ix;
163   Tcl_InvalidateStringRep(o);
164   return o;
165 }
166
167 void cht_tabledataid_disposing(Tcl_Interp *ip, void *val, const IdDataSpec *idds) {
168   IdDataAssocData *assoc;
169   int ix;
170
171   ix= *(int*)val;
172   if (ix==-1) return;
173
174   assoc= Tcl_GetAssocData(ip, (char*)idds->assockey, 0);
175   assert(assoc->a[ix] == val);
176   assoc->a[ix]= 0;
177   *(int*)val= -1;
178 }
179
180 static int tabledataid_nt_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
181   abort();
182 }
183
184 static void tabledataid_nt_free(Tcl_Obj *o) {
185   TFREE(o->internalRep.otherValuePtr);
186   o->internalRep.otherValuePtr= 0;
187 }
188
189 static void tabledataid_nt_dup(Tcl_Obj *src, Tcl_Obj *dup) {
190   IdDataValue *sv, *dv;
191
192   sv= src->internalRep.otherValuePtr;
193   dv= TALLOC(sizeof(*dv));
194   *dv= *sv;
195   dup->typePtr= &cht_tabledataid_nearlytype;
196   dup->internalRep.otherValuePtr= dv;
197 }
198
199 static void tabledataid_nt_ustr(Tcl_Obj *o) {
200   const IdDataValue *dv;
201   const IdDataAssocData *assoc;
202   const IdDataSpec *idds;
203   char buf[75];
204
205   dv= o->internalRep.otherValuePtr;
206   assoc= dv->assoc;
207   idds= assoc->idds;
208
209   snprintf(buf,sizeof(buf), "%d", dv->ix);
210   cht_obj_updatestr_vstringls(o,
211                           idds->valprefix, strlen(idds->valprefix),
212                           buf, strlen(buf),
213                           (char*)0);
214 }
215
216 Tcl_ObjType cht_tabledataid_nearlytype = {
217   "tabledataid",
218   tabledataid_nt_free, tabledataid_nt_dup,
219   tabledataid_nt_ustr, tabledataid_nt_sfa
220 };