base/idtable.c

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