X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?a=blobdiff_plain;ds=sidebyside;f=base%2Fidtable.c;h=6e7aafaa1562c94b8f16398acc4a6acfb42622cc;hb=5dc0c5b5a5d8b47aebe392186cf9afcdfc1d221f;hp=d2f3e04a59040ea2961d0a7ac6c4a81a503406b5;hpb=a41625aefb08ed5bf5f07951841bdfe30c4a72c7;p=chiark-tcl.git

diff --git a/base/idtable.c b/base/idtable.c
index d2f3e04..6e7aafa 100644
--- a/base/idtable.c
+++ b/base/idtable.c
@@ -1,60 +1,122 @@
 /*
- */
-/*
- * dgram-socket create <local>                        => <sockid>
- * dgram-socket close <sockid>
- * dgram-socket transmit <sockid> <data> <remote>
- * dgram-socket on-receive <sockid> [<script>]
- *    calls, effectively,  eval <script> [list <data> <remote-addr> <socket>]
- *    if script not supplied, cancel
+ * base code for various Tcl extensions
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
  */
 
-#include "tables.h"
-#include "hbytes.h"
+#include "chiark-tcl-base.h"
 
 /* Arg parsing */
 
-static void setobjdataid(Tcl_Obj *o, int ix, IdDataTable *tab) {
-  unsigned long *ulp;
+typedef struct {
+  const IdDataSpec *idds;
+  int n;
+  void **a;
+} IdDataAssocData;
+
+typedef struct {
+  Tcl_Interp *interp;
+  IdDataAssocData *assoc;
+  int ix;
+} IdDataValue;
+
+static void assoc_del(ClientData assoc_cd, Tcl_Interp *ip) {
+  IdDataAssocData *assoc;
+  int ix;
+  void **p, *v;
+
+  assoc= assoc_cd;
+  for (ix=0, p=assoc->a; ix<assoc->n; ix++, p++) {
+    v= *p;
+    if (!v) continue;
+    assert(*(int*)v == ix);
+    *(int*)v= -1;
+    assoc->idds->destroyitem(ip,v);
+    *p= 0;
+  }
+  TFREE(assoc->a);
+  TFREE(assoc);
+}
+
+static void setobjdataid(Tcl_Interp *interp, Tcl_Obj *o,
+			 int ix, const IdDataSpec *idds) {
+  IdDataValue *dv;
+  IdDataAssocData *assoc;
+
+  assoc= Tcl_GetAssocData(interp, (char*)idds->assockey, 0);
+  if (!assoc) {
+    assoc= TALLOC(sizeof(*assoc));
+    assoc->idds= idds;
+    assoc->n= 0;
+    assoc->a= 0;
+    Tcl_SetAssocData(interp, (char*)idds->assockey, assoc_del, assoc);
+  }
+  
+  dv= TALLOC(sizeof(*dv));
+  dv->interp= interp;
+  dv->assoc= assoc;
+  dv->ix= ix;
   
-  ulp= TALLOC(sizeof(unsigned long));
-  *ulp= ix;
-  o->internalRep.twoPtrValue.ptr1= tab;
-  o->internalRep.twoPtrValue.ptr2= ulp;
-  o->typePtr= &tabledataid_nearlytype;
+  o->typePtr= &cht_tabledataid_nearlytype;
+  o->internalRep.otherValuePtr= dv;
 }
 
-int tabledataid_parse(Tcl_Interp *ip, Tcl_Obj *o, IdDataTable *tab) {
+int cht_tabledataid_parse(Tcl_Interp *ip, Tcl_Obj *o, const IdDataSpec *idds) {
   int l;
   unsigned long ul;
+  IdDataValue *dv;
   char *ep, *str;
 
-  if (o->typePtr == &tabledataid_nearlytype &&
-      o->internalRep.twoPtrValue.ptr1 == tab) return TCL_OK;
+  if (o->typePtr != &cht_tabledataid_nearlytype) goto convert;
+
+  dv= o->internalRep.otherValuePtr;
+  if (dv->interp != ip) goto convert;
+  if (dv->assoc->idds != idds) goto convert;
+
+  return TCL_OK;
 
-  l= strlen(tab->prefix);
+convert:
+  l= strlen(idds->valprefix);
   str= Tcl_GetStringFromObj(o,0);
-  if (memcmp(str,tab->prefix,l))
-    return staticerr(ip,"bad id (wrong prefix)",0);
+  if (memcmp(str,idds->valprefix,l))
+    return cht_staticerr(ip,"bad id (wrong prefix)",0);
+
   errno=0; ul=strtoul(str+l,&ep,10);
-  if (errno || *ep) return staticerr(ip,"bad id number",0);
-  if (ul > INT_MAX) return staticerr(ip,"out of range id number",0);
+  if (errno || *ep) return cht_staticerr(ip,"bad id number",0);
+  if (ul > INT_MAX) return cht_staticerr(ip,"out of range id number",0);
 
-  objfreeir(o);
-  setobjdataid(o,ul,tab);
+  cht_objfreeir(o);
+  setobjdataid(ip,o,ul,idds);
   return TCL_OK;
 }
 
-int pat_iddata(Tcl_Interp *ip, Tcl_Obj *o, void **rv, IdDataTable *tab) {
+int cht_pat_iddata(Tcl_Interp *ip, Tcl_Obj *o, void **rv, const IdDataSpec *idds) {
   int rc, ix;
+  IdDataValue *dv;
+  IdDataAssocData *assoc;
   void *r;
   
-  rc= tabledataid_parse(ip,o,tab);
+  rc= cht_tabledataid_parse(ip,o,idds);
   if (rc) return rc;
 
-  ix= *(unsigned long*)o->internalRep.twoPtrValue.ptr2;
-  if (ix >= tab->n || !(r= tab->a[ix]))
-    return staticerr(ip,"id not in use",0);
+  dv= o->internalRep.otherValuePtr;
+  ix= dv->ix;
+  assoc= dv->assoc;
+
+  if (ix >= assoc->n || !(r= assoc->a[ix]))
+    return cht_staticerr(ip,"id not in use",0);
 
   assert(*(int*)r == ix);
 
@@ -62,64 +124,92 @@ int pat_iddata(Tcl_Interp *ip, Tcl_Obj *o, void **rv, IdDataTable *tab) {
   return TCL_OK;
 }
 
-Tcl_Obj *ret_iddata(Tcl_Interp *ip, void *val, IdDataTable *tab) {
+Tcl_Obj *cht_ret_iddata(Tcl_Interp *ip, void *val, const IdDataSpec *idds) {
   /* Command procedure implementation may set val->ix,
    * ie *(int*)val, to -1, to mean it's a new struct.  Otherwise
    * it had better be an old one !
    */
   Tcl_Obj *o;
+  IdDataValue *dv;
+  IdDataAssocData *assoc;
   int ix;
 
+  o= Tcl_NewObj();
+  setobjdataid(ip,o,0,idds);
+  dv= o->internalRep.otherValuePtr;
+  assoc= dv->assoc;
+
   ix= *(int*)val;
   if (ix==-1) {
-    for (ix=0; ix<tab->n && tab->a[ix]; ix++);
-    if (ix>=tab->n) {
-      tab->n += 2;
-      tab->n *= 2;
-      tab->a= (void*)Tcl_Realloc((void*)tab->a, tab->n*sizeof(*tab->a));
-      while (ix<tab->n) tab->a[ix++]=0;
+    for (ix=0; ix<assoc->n && assoc->a[ix]; ix++);
+    if (ix>=assoc->n) {
+      assert(assoc->n < INT_MAX/4);
+      assoc->n += 2;
+      assoc->n *= 2;
+      assoc->a= TREALLOC(assoc->a, assoc->n*sizeof(*assoc->a));
+      while (ix<assoc->n) assoc->a[ix++]=0;
       ix--;
     }
-    tab->a[ix]= val;
+    assoc->a[ix]= val;
     *(int*)val= ix;
   } else {
-    assert(val == tab->a[ix]);
+    assert(val == assoc->a[ix]);
   }
-
-  o= Tcl_NewObj();
-  setobjdataid(o,ix,tab);
+  dv->ix= ix;
   Tcl_InvalidateStringRep(o);
   return o;
 }
 
+void cht_tabledataid_disposing(Tcl_Interp *ip, void *val, const IdDataSpec *idds) {
+  IdDataAssocData *assoc;
+  int ix;
+
+  ix= *(int*)val;
+  if (ix==-1) return;
+
+  assoc= Tcl_GetAssocData(ip, (char*)idds->assockey, 0);
+  assert(assoc->a[ix] == val);
+  assoc->a[ix]= 0;
+  *(int*)val= -1;
+}
+
 static int tabledataid_nt_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
   abort();
 }
 
 static void tabledataid_nt_free(Tcl_Obj *o) {
-  TFREE(o->internalRep.twoPtrValue.ptr2);
-  o->internalRep.twoPtrValue.ptr2= 0;
+  TFREE(o->internalRep.otherValuePtr);
+  o->internalRep.otherValuePtr= 0;
 }
 
 static void tabledataid_nt_dup(Tcl_Obj *src, Tcl_Obj *dup) {
-  setobjdataid(dup,*(unsigned long*)src->internalRep.twoPtrValue.ptr2,
-	       src->internalRep.twoPtrValue.ptr1);
+  IdDataValue *sv, *dv;
+
+  sv= src->internalRep.otherValuePtr;
+  dv= TALLOC(sizeof(*dv));
+  *dv= *sv;
+  dup->typePtr= &cht_tabledataid_nearlytype;
+  dup->internalRep.otherValuePtr= dv;
 }
 
 static void tabledataid_nt_ustr(Tcl_Obj *o) {
+  const IdDataValue *dv;
+  const IdDataAssocData *assoc;
+  const IdDataSpec *idds;
   char buf[75];
-  const char *prefix;
 
-  prefix= o->internalRep.twoPtrValue.ptr2;
-  snprintf(buf,sizeof(buf), "%lu",
-	   *(unsigned long*)o->internalRep.twoPtrValue.ptr2);
-  obj_updatestr_vstringls(o,
-			  prefix, strlen(prefix),
+  dv= o->internalRep.otherValuePtr;
+  assoc= dv->assoc;
+  idds= assoc->idds;
+
+  snprintf(buf,sizeof(buf), "%d", dv->ix);
+  cht_obj_updatestr_vstringls(o,
+			  idds->valprefix, strlen(idds->valprefix),
 			  buf, strlen(buf),
 			  (char*)0);
 }
 
-Tcl_ObjType tabledataid_nearlytype = {
+Tcl_ObjType cht_tabledataid_nearlytype = {
   "tabledataid",
   tabledataid_nt_free, tabledataid_nt_dup,
   tabledataid_nt_ustr, tabledataid_nt_sfa