Attachment "cons.patch" to
ticket [1993441fff]
added by
ferrieux
2008-06-14 05:53:01.
Index: tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.301
diff -b -u -r1.301 tclBasic.c
--- tclBasic.c 8 Jun 2008 03:21:31 -0000 1.301
+++ tclBasic.c 13 Jun 2008 22:20:42 -0000
@@ -697,6 +697,13 @@
Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble",
Tcl_DisassembleObjCmd, NULL, NULL);
+
+ /*
+ * Create a command for creating Cons'es.
+ */
+
+ Tcl_CreateObjCommand(interp, "cons",
+ Tcl_ConsObjCmd, NULL, NULL);
#ifdef USE_DTRACE
/*
Index: tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.370
diff -b -u -r1.370 tclInt.h
--- tclInt.h 6 Jun 2008 19:46:37 -0000 1.370
+++ tclInt.h 13 Jun 2008 22:20:59 -0000
@@ -2975,6 +2979,11 @@
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_ConsObjCmd(ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[]);
+
/*
*----------------------------------------------------------------
* Compilation procedures for commands in the generic core:
Index: tclListObj.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclListObj.c,v
retrieving revision 1.50
diff -b -u -r1.50 tclListObj.c
--- tclListObj.c 27 Apr 2008 22:21:30 -0000 1.50
+++ tclListObj.c 13 Jun 2008 22:21:04 -0000
@@ -25,6 +25,9 @@
static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfList(Tcl_Obj *listPtr);
+static void FreeConsInternalRep(Tcl_Obj *listPtr);
+static void UpdateStringOfCons(Tcl_Obj *listPtr);
+
/*
* The structure below defines the list Tcl object type by means of functions
* that can be invoked by generic object code.
@@ -46,6 +49,14 @@
SetListFromAny /* setFromAnyProc */
};
+Tcl_ObjType tclConsType = {
+ "cons", /* name */
+ FreeConsInternalRep, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ UpdateStringOfCons, /* updateStringProc */
+ NULL /* setFromAnyProc */
+};
+
/*
*----------------------------------------------------------------------
*
@@ -193,6 +204,57 @@
}
#endif /* if TCL_MEM_DEBUG */
+static Tcl_Obj *
+Tcl_NewConsObj(Tcl_Obj *a,Tcl_Obj *b)
+{
+ Tcl_Obj *consPtr;
+
+ TclNewObj(consPtr);
+ Tcl_InvalidateStringRep(consPtr);
+ consPtr->internalRep.twoPtrValue.ptr1 = a;
+ Tcl_IncrRefCount(a);
+ consPtr->internalRep.twoPtrValue.ptr2 = b;
+ Tcl_IncrRefCount(b);
+ consPtr->typePtr = &tclConsType;
+
+ return consPtr;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ConsObjCmd --
+ *
+ * This procedure is invoked to process the "cons" Tcl command. See the
+ * user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ConsObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
+{
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "elem1 elem2");
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewConsObj(objv[1],objv[2]));
+ return TCL_OK;
+}
+
+
+
/*
*----------------------------------------------------------------------
*
@@ -425,6 +487,11 @@
{
register List *listRepPtr;
+ if (listPtr->typePtr == &tclConsType) {
+ *objcPtr = 2;
+ *objvPtr = (Tcl_Obj **)&listPtr->internalRep.twoPtrValue.ptr1;
+ return TCL_OK;
+ }
if (listPtr->typePtr != &tclListType) {
int result, length;
@@ -654,6 +721,15 @@
{
register List *listRepPtr;
+ if (listPtr->typePtr == &tclConsType) {
+ if ((index < 0) || (index > 1)) {
+ *objPtrPtr = NULL;
+ } else {
+ *objPtrPtr = (Tcl_Obj *)(index ? listPtr->internalRep.twoPtrValue.ptr2 : listPtr->internalRep.twoPtrValue.ptr1 );
+ }
+ return TCL_OK;
+ }
+
if (listPtr->typePtr != &tclListType) {
int result, length;
@@ -709,6 +785,10 @@
{
register List *listRepPtr;
+ if (listPtr->typePtr == &tclConsType) {
+ *intPtr = 2;
+ return TCL_OK;
+ }
if (listPtr->typePtr != &tclListType) {
int result, length;
@@ -1593,6 +1673,32 @@
listPtr->internalRep.twoPtrValue.ptr1 = NULL;
listPtr->internalRep.twoPtrValue.ptr2 = NULL;
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeConsInternalRep --
+ *
+ * Decrements the refcounts of both cons elements.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Sets consPtr's internalRep.twoPtrValue.ptr1,2 to NULL.
+ * Decrements the ref counts of both element objects, which may free them.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeConsInternalRep(
+ Tcl_Obj *consPtr) /* Cons object with members to unlink. */
+{
+ Tcl_DecrRefCount((Tcl_Obj *)consPtr->internalRep.twoPtrValue.ptr1);
+ Tcl_DecrRefCount((Tcl_Obj *)consPtr->internalRep.twoPtrValue.ptr2);
+ consPtr->internalRep.twoPtrValue.ptr1 = NULL;
+ consPtr->internalRep.twoPtrValue.ptr2 = NULL;
+}
/*
*----------------------------------------------------------------------
@@ -1845,6 +1951,78 @@
listRepPtr->canonicalFlag = 1;
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfCons --
+ *
+ * Update the string representation for a cons object. Note: This
+ * function does not invalidate an existing old string rep so storage
+ * will be lost if this has not already been done.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Just like UpdateStringOfList for a two-element list.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfCons(
+ Tcl_Obj *consPtr) /* Cons object with string rep to update. */
+{
+ int localFlags[2], *flagPtr;
+ register int i;
+ char *elem, *dst;
+ int length;
+
+ /*
+ * Convert each element of the cons to string form and then convert it to
+ * proper list/cons element form, adding it to the result buffer.
+ */
+
+ /*
+ * Pass 1: estimate space, gather flags.
+ */
+
+ flagPtr = localFlags;
+ consPtr->length = 1;
+ for (i = 0; i < 2; i++) {
+ elem = TclGetStringFromObj( (Tcl_Obj *)(i ? consPtr->internalRep.twoPtrValue.ptr2 : consPtr->internalRep.twoPtrValue.ptr1 ), &length);
+ consPtr->length += Tcl_ScanCountedElement(elem, length, flagPtr+i)+1;
+
+ /*
+ * Check for continued sanity. [Bug 1267380]
+ */
+
+ if (consPtr->length < 1) {
+ Tcl_Panic("string representation size exceeds sane bounds");
+ }
+ }
+
+ /*
+ * Pass 2: copy into string rep buffer.
+ */
+
+ consPtr->bytes = ckalloc((unsigned) consPtr->length);
+ dst = consPtr->bytes;
+ for (i = 0; i < 2; i++) {
+ elem = TclGetStringFromObj((Tcl_Obj *)(i ? consPtr->internalRep.twoPtrValue.ptr2 : consPtr->internalRep.twoPtrValue.ptr1 ), &length);
+ dst += Tcl_ConvertCountedElement(elem, length, dst,
+ flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH));
+ *dst = ' ';
+ dst++;
+ }
+ if (dst == consPtr->bytes) {
+ *dst = 0;
+ } else {
+ dst--;
+ *dst = 0;
+ }
+ consPtr->length = dst - consPtr->bytes;
+}
/*
* Local Variables:
