/*
 * tclTestABSList.c --
 *
 *	This file contains testing code: abstract list definitions for the
 *	"lstring" and "lgen" testing commands.
 *
 * Copyright © 2022-2023 by Brian Griffin
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#undef BUILD_tcl
#undef STATIC_BUILD
#ifndef USE_TCL_STUBS
#   define USE_TCL_STUBS
#endif
#include <string.h>
#include <limits.h>
#include "tclInt.h"

/*
 * Forward references
 */

static void		LgenSeriesDupIntRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void		LgenSeriesFreeIntRep(Tcl_Obj *);
static int		LgenSeriesIndex(Tcl_Interp *interp,
			    Tcl_Obj *lgenSeriesObjPtr, Tcl_Size index,
			    Tcl_Obj **elemPtr);
static Tcl_Size		LgenSeriesLength(Tcl_Obj *objPtr);
static void		LgenSeriesUpdateString(Tcl_Obj *objPtr);
static Tcl_Obj *	NewLStringObj(Tcl_Interp *interp, Tcl_Size objc,
			    Tcl_Obj *const *objv);
static void		LStringFreeRep(Tcl_Obj *alObj);
static Tcl_Obj *	LStringSetElem(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    Tcl_Size numIndcies, Tcl_Obj *const indicies[],
			    Tcl_Obj *valueObj);
static void		LStringDupRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static Tcl_Size		LStringLength(Tcl_Obj *lstringObjPtr);
static int		LStringIndex(Tcl_Interp *interp, Tcl_Obj *lstringObj,
			    Tcl_Size index, Tcl_Obj **charObjPtr);
static int		LStringRange(Tcl_Interp *interp, Tcl_Obj *lstringObj,
			    Tcl_Size fromIdx, Tcl_Size toIdx, Tcl_Obj **newObjPtr);
static int		LStringReverse(Tcl_Interp *interp, Tcl_Obj *srcObj,
			    Tcl_Obj **newObjPtr);
static int		LStringReplace(Tcl_Interp *interp, Tcl_Obj *listObj,
			    Tcl_Size first, Tcl_Size numToDelete, Tcl_Size numToInsert,
			    Tcl_Obj *const insertObjs[]);
static int		LStringGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    Tcl_Size *objcptr, Tcl_Obj ***objvptr);
static void		LStringFreeElements(Tcl_Obj *lstringObj);
static void		LStringUpdateString(Tcl_Obj *objPtr);

/*
 * Internal Representation of an lstring type value
 */

typedef struct LString {
    char *string;		// NULL terminated utf-8 string
    Tcl_Size strlen;		// num bytes in string
    Tcl_Size allocated;		// num bytes allocated
    Tcl_Obj **elements;		// elements array, allocated when GetElements is
				// called
} LString;

/*
 * Internal rep for the Generate Series
 */
typedef struct LgenSeries {
    Tcl_Interp *interp;		// used to evaluate gen script
    Tcl_Size len;		// list length
    Tcl_Size nargs;		// Number of arguments in genFn including "index"
    Tcl_Obj *genFnObj;		// The preformed command as a list. Index is set in
				// the last element (last argument)
} LgenSeries;

/*
 * AbstractList definition of an lstring type
 */
static const Tcl_ObjType lstringTypes[11] = {
    {/*0*/
	"lstring",
	LStringFreeRep,
	LStringDupRep,
	LStringUpdateString,
	NULL,			// SetFromAny
	TCL_OBJTYPE_V2(
	    LStringLength,
	    LStringIndex,
	    LStringRange,
	    LStringReverse,
	    LStringGetElements,
	    LStringSetElem,
	    LStringReplace,
	    NULL)		// "in" operator
	},
    {/*1*/
	"lstring",
	LStringFreeRep,
	LStringDupRep,
	LStringUpdateString,
	NULL,			// SetFromAny
	TCL_OBJTYPE_V2(
	    NULL,		// Length
	    LStringIndex,
	    LStringRange,
	    LStringReverse,
	    LStringGetElements,
	    LStringSetElem,
	    LStringReplace,
	    NULL)		// "in" operator
    },
    {/*2*/
	"lstring",
	LStringFreeRep,
	LStringDupRep,
	LStringUpdateString,
	NULL,			// SetFromAny
	TCL_OBJTYPE_V2(
	    LStringLength,
	    NULL,		// Index
	    LStringRange,
	    LStringReverse,
	    LStringGetElements,
	    LStringSetElem,
	    LStringReplace,
	    NULL)		// "in" operator
    },
    {/*3*/
	"lstring",
	LStringFreeRep,
	LStringDupRep,
	LStringUpdateString,
	NULL,			// SetFromAny
	TCL_OBJTYPE_V2(
	    LStringLength,
	    LStringIndex,
	    NULL,		// Slice
	    LStringReverse,
	    LStringGetElements,
	    LStringSetElem,
	    LStringReplace,
	    NULL)		// "in" operator
    },
    {/*4*/
	"lstring",
	LStringFreeRep,
	LStringDupRep,
	LStringUpdateString,
	NULL,			// SetFromAny
	TCL_OBJTYPE_V2(
	    LStringLength,
	    LStringIndex,
	    LStringRange,
	    NULL,		// Reverse
	    LStringGetElements,
	    LStringSetElem,
	    LStringReplace,
	    NULL)		// "in" operator
    },
    {/*5*/
	"lstring",
	LStringFreeRep,
	LStringDupRep,
	LStringUpdateString,
	NULL,			// SetFromAny
	TCL_OBJTYPE_V2(
	    LStringLength,
	    LStringIndex,
	    LStringRange,
	    LStringReverse,
	    NULL,		// GetElements
	    LStringSetElem,
	    LStringReplace,
	    NULL)		// "in" operator
    },
    {/*6*/
	"lstring",
	LStringFreeRep,
	LStringDupRep,
	LStringUpdateString,
	NULL,			// SetFromAny
	TCL_OBJTYPE_V2(
	    LStringLength,
	    LStringIndex,
	    LStringRange,
	    LStringReverse,
	    LStringGetElements,
	    NULL,		// SetElement
	    LStringReplace,
	    NULL)		// "in" operator
    },
    {/*7*/
	"lstring",
	LStringFreeRep,
	LStringDupRep,
	LStringUpdateString,
	NULL,			// SetFromAny
	TCL_OBJTYPE_V2(
	    LStringLength,
	    LStringIndex,
	    LStringRange,
	    LStringReverse,
	    LStringGetElements,
	    LStringSetElem,
	    NULL,		// Replace
	    NULL)		// "in" operator
    },
    {/*8*/
	"lstring",
	LStringFreeRep,
	LStringDupRep,
	LStringUpdateString,
	NULL,			// SetFromAny
	TCL_OBJTYPE_V2(
	    LStringLength,
	    LStringIndex,
	    LStringRange,
	    LStringReverse,
	    LStringGetElements,
	    LStringSetElem,
	    LStringReplace,
	    NULL)		// "in" operator
    },
    {/*9*/
	"lstring",
	LStringFreeRep,
	LStringDupRep,
	LStringUpdateString,
	NULL,			// SetFromAny
	TCL_OBJTYPE_V2(
	    LStringLength,
	    LStringIndex,
	    LStringRange,
	    LStringReverse,
	    LStringGetElements,
	    LStringSetElem,
	    LStringReplace,
	    NULL)		// "in" operator
    },
    {/*10*/
	"lstring",
	LStringFreeRep,
	LStringDupRep,
	LStringUpdateString,
	NULL,			// SetFromAny
	TCL_OBJTYPE_V2(
	    LStringLength,
	    LStringIndex,
	    LStringRange,
	    LStringReverse,
	    LStringGetElements,
	    LStringSetElem,
	    LStringReplace,
	    NULL)		// "in" operator
    }
};

/*
 * Abstract List ObjType definition
 */
static const Tcl_ObjType lgenSeriesType = {
    "lgenseries",
    LgenSeriesFreeIntRep,
    LgenSeriesDupIntRep,
    LgenSeriesUpdateString,
    NULL,			// SetFromAny
    TCL_OBJTYPE_V2(
	LgenSeriesLength,
	LgenSeriesIndex,
	NULL,			// Slice
	NULL,			// Reverse
	NULL,			// Get elements
	NULL,			// Set element
	NULL,			// Replace
	NULL)			// "in" operator
};

/*
 *----------------------------------------------------------------------
 *
 * LStringIndex --
 *
 *	Implements the AbstractList Index function for the lstring type.  The
 *	Index function returns the value at the index position given. Caller
 *	is resposible for freeing the Obj.
 *
 * Results:
 *	TCL_OK on success. Returns a new Obj, with a 0 refcount in the
 *	supplied charObjPtr location. Call has ownership of the Obj.
 *
 * Side effects:
 *	Obj allocated.
 *
 *----------------------------------------------------------------------
 */
static int
LStringIndex(
    Tcl_Interp *interp,
    Tcl_Obj *lstringObj,
    Tcl_Size index,
    Tcl_Obj **charObjPtr)
{
    LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;

    (void)interp;

    if (index < lstringRepPtr->strlen) {
	char cchar[2];
	cchar[0] = lstringRepPtr->string[index];
	cchar[1] = 0;
	*charObjPtr = Tcl_NewStringObj(cchar,1);
    } else {
	*charObjPtr = NULL;
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * LStringLength --
 *
 *	Implements the AbstractList Length function for the lstring type.
 *	The Length function returns the number of elements in the list.
 *
 * Results:
 *	WideInt number of elements in the list.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */
static Tcl_Size
LStringLength(
    Tcl_Obj *lstringObjPtr)
{
    LString *lstringRepPtr = (LString *)lstringObjPtr->internalRep.twoPtrValue.ptr1;
    return lstringRepPtr->strlen;
}

/*
 *----------------------------------------------------------------------
 *
 * LStringDupRep --
 *
 *	Replicates the internal representation of the src value, and storing
 *	it in the copy
 *
 * Results:
 *	None
 *
 * Side effects:
 *	Modifies the rep of the copyObj.
 *
 *----------------------------------------------------------------------
 */
static void
LStringDupRep(
    Tcl_Obj *srcPtr,
    Tcl_Obj *copyPtr)
{
    LString *srcLString = (LString*)srcPtr->internalRep.twoPtrValue.ptr1;
    LString *copyLString = (LString*)Tcl_Alloc(sizeof(LString));

    memcpy(copyLString, srcLString, sizeof(LString));
    copyLString->string = (char*)Tcl_Alloc(srcLString->allocated);
    strncpy(copyLString->string, srcLString->string, srcLString->strlen);
    copyLString->string[srcLString->strlen] = '\0';
    copyLString->elements = NULL;
    Tcl_ObjInternalRep itr;
    itr.twoPtrValue.ptr1 = copyLString;
    itr.twoPtrValue.ptr2 = NULL;
    Tcl_StoreInternalRep(copyPtr, srcPtr->typePtr, &itr);
}

/*
 *----------------------------------------------------------------------
 *
 * LStringSetElem --
 *
 *	Replace the element value at the given (nested) index with the
 *	valueObj provided.  If the lstring obj is shared, a new list is
 *	created conntaining the modifed element.
 *
 * Results:
 *	The modifed lstring is returned, either new or original. If the
 *	index is invalid, NULL is returned, and an error is added to the
 *	interp, if provided.
 *
 * Side effects:
 *	A new obj may be created.
 *
 *----------------------------------------------------------------------
 */
static Tcl_Obj *
LStringSetElem(
    Tcl_Interp *interp,
    Tcl_Obj *lstringObj,
    Tcl_Size numIndicies,
    Tcl_Obj *const indicies[],
    Tcl_Obj *valueObj)
{
    LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;
    Tcl_Size index;
    int status;
    Tcl_Obj *returnObj;

    if (numIndicies > 1) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"Multiple indicies not supported by lstring."));
	return NULL;
    }

    status = Tcl_GetIntForIndex(interp, indicies[0], lstringRepPtr->strlen, &index);
    if (status != TCL_OK) {
	return NULL;
    }

    returnObj = Tcl_IsShared(lstringObj) ? Tcl_DuplicateObj(lstringObj) : lstringObj;
    lstringRepPtr = (LString*)returnObj->internalRep.twoPtrValue.ptr1;

    if (index >= lstringRepPtr->strlen) {
	index = lstringRepPtr->strlen;
	lstringRepPtr->strlen++;
	lstringRepPtr->string = (char*)Tcl_Realloc(lstringRepPtr->string, lstringRepPtr->strlen+1);
    }

    if (valueObj) {
	const char newvalue = Tcl_GetString(valueObj)[0];
	lstringRepPtr->string[index] = newvalue;
    } else if (index < lstringRepPtr->strlen) {
	/* Remove the char by sliding the tail of the string down */
	char *sptr = &lstringRepPtr->string[index];
	/* This is an overlapping copy, by definition */
	lstringRepPtr->strlen--;
	memmove(sptr, (sptr+1), (lstringRepPtr->strlen - index));
    }
    // else do nothing

    Tcl_InvalidateStringRep(returnObj);

    return returnObj;
}

/*
 *----------------------------------------------------------------------
 *
 * LStringRange --
 *
 *	Creates a new Obj with a slice of the src listPtr.
 *
 * Results:
 *	A new Tcl_Obj is assigned to newObjPtr. Returns TCL_OK
 *
 * Side effects:
 *	A new Obj is created.
 *
 *----------------------------------------------------------------------
 */
static int
LStringRange(
    Tcl_Interp *interp,
    Tcl_Obj *lstringObj,
    Tcl_Size fromIdx,
    Tcl_Size toIdx,
    Tcl_Obj **newObjPtr)
{
    Tcl_Obj *rangeObj;
    LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;
    LString *rangeRep;
    Tcl_WideInt len = toIdx - fromIdx + 1;

    if (lstringRepPtr->strlen < fromIdx ||
	    lstringRepPtr->strlen < toIdx) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf("Range out of bounds "));
	return TCL_ERROR;
    }

    if (len <= 0) {
	// Return empty value;
	*newObjPtr = Tcl_NewObj();
    } else {
	rangeRep = (LString*)Tcl_Alloc(sizeof(LString));
	rangeRep->allocated = len+1;
	rangeRep->strlen = len;
	rangeRep->string = (char*)Tcl_Alloc(rangeRep->allocated);
	strncpy(rangeRep->string,&lstringRepPtr->string[fromIdx],len);
	rangeRep->string[len] = 0;
	rangeRep->elements = NULL;
	rangeObj = Tcl_NewObj();
	Tcl_ObjInternalRep itr;
	itr.twoPtrValue.ptr1 = rangeRep;
	itr.twoPtrValue.ptr2 = NULL;
	Tcl_StoreInternalRep(rangeObj, lstringObj->typePtr, &itr);
	if (rangeRep->strlen > 0) {
	    Tcl_InvalidateStringRep(rangeObj);
	} else {
	    Tcl_InitStringRep(rangeObj, NULL, 0);
	}
	*newObjPtr = rangeObj;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * LStringReverse --
 *
 *	Creates a new Obj with the order of the elements in the lstring
 *	value reversed, where first is last and last is first, etc.
 *
 * Results:
 *	A new Obj is assigned to newObjPtr. Returns TCL_OK
 *
 * Side effects:
 *	Memory is allocated.
 *
 *----------------------------------------------------------------------
 */
static int
LStringReverse(
    Tcl_Interp *interp,
    Tcl_Obj *srcObj,
    Tcl_Obj **newObjPtr)
{
    LString *srcRep = (LString*)srcObj->internalRep.twoPtrValue.ptr1;
    Tcl_Obj *revObj;
    LString *revRep = (LString*)Tcl_Alloc(sizeof(LString));
    Tcl_ObjInternalRep itr;
    Tcl_Size len;
    char *srcp, *dstp, *endp;
    (void)interp;
    len = srcRep->strlen;
    revRep->strlen = len;
    revRep->allocated = len+1;
    revRep->string = (char*)Tcl_Alloc(revRep->allocated);
    revRep->elements = NULL;
    srcp = srcRep->string;
    endp = &srcRep->string[len];
    dstp = &revRep->string[len];
    *dstp-- = 0;
    while (srcp < endp) {
	*dstp-- = *srcp++;
    }
    revObj = Tcl_NewObj();
    itr.twoPtrValue.ptr1 = revRep;
    itr.twoPtrValue.ptr2 = NULL;
    Tcl_StoreInternalRep(revObj, srcObj->typePtr, &itr);
    if (revRep->strlen > 0) {
	Tcl_InvalidateStringRep(revObj);
    } else {
	Tcl_InitStringRep(revObj, NULL, 0);
    }
    *newObjPtr = revObj;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * LStringReplace --
 *
 *	Delete and/or Insert elements in the list, starting at index first.
 *	See more details in the comments below. This should not be called with
 *	a Shared Obj.
 *
 * Results:
 *	The value of the listObj is modified.
 *
 * Side effects:
 *	The string rep is invalidated.
 *
 *----------------------------------------------------------------------
 */
static int
LStringReplace(
    Tcl_Interp *interp,
    Tcl_Obj *listObj,
    Tcl_Size first,
    Tcl_Size numToDelete,
    Tcl_Size numToInsert,
    Tcl_Obj *const insertObjs[])
{
    LString *lstringRep = (LString*)listObj->internalRep.twoPtrValue.ptr1;
    Tcl_Size newLen;
    Tcl_Size x, ix, kx;
    char *newStr;
    char *oldStr = lstringRep->string;
    (void)interp;

    newLen = lstringRep->strlen - numToDelete + numToInsert;

    if (newLen >= lstringRep->allocated) {
	lstringRep->allocated = newLen+1;
	newStr = (char*)Tcl_Alloc(lstringRep->allocated);
	newStr[newLen] = 0;
    } else {
	newStr = oldStr;
    }

    /* Tcl_ListObjReplace replaces zero or more elements of the list
     * referenced by listPtr with the objc values in the array referenced by
     * objv.
     *
     * If listPtr does not point to a list value, Tcl_ListObjReplace
     * will attempt to convert it to one; if the conversion fails, it returns
     * TCL_ERROR and leaves an error message in the interpreter's result value
     * if interp is not NULL. Otherwise, it returns TCL_OK after replacing the
     * values.
     *
     *    * If objv is NULL, no new elements are added.
     *
     *    * If the argument first is zero or negative, it refers to the first
     *      element.
     *
     *    * If first is greater than or equal to the number of elements in the
     *      list, then no elements are deleted; the new elements are appended
     *      to the list. count gives the number of elements to replace.
     *
     *    * If count is zero or negative then no elements are deleted; the new
     *      elements are simply inserted before the one designated by first.
     *      Tcl_ListObjReplace invalidates listPtr's old string representation.
     *
     *    * The reference counts of any elements inserted from objv are
     *      incremented since the resulting list now refers to them. Similarly,
     *      the reference counts for any replaced values are decremented.
     */

    // copy 0 to first-1
    if (newStr != oldStr) {
	strncpy(newStr, oldStr, first);
    }

    // move front elements to keep
    for (x=0, kx=0; x<newLen && kx<first; kx++, x++) {
	newStr[x] = oldStr[kx];
    }
    // Insert new elements into new string
    for (x=first, ix=0; ix<numToInsert; x++, ix++) {
	char const *svalue = Tcl_GetString(insertObjs[ix]);
	newStr[x] = svalue[0];
    }
    // Move remaining elements
    if (first + numToDelete < newLen) {
	for (/*x,*/ kx=first+numToDelete; (kx <lstringRep->strlen && x<newLen); x++, kx++) {
	    newStr[x] = oldStr[kx];
	}
    }

    // Terminate new string.
    newStr[newLen] = 0;

    if (oldStr != newStr) {
	Tcl_Free(oldStr);
    }
    lstringRep->string = newStr;
    lstringRep->strlen = newLen;

    /* Changes made to value, string rep and elements array no longer valid */
    Tcl_InvalidateStringRep(listObj);
    LStringFreeElements(listObj);

    return TCL_OK;
}

static inline const Tcl_ObjType *
GetLStringType(
    int ptype)
{
    const Tcl_ObjType *typePtr = &lstringTypes[0]; /* default value */
    if (4 <= ptype && ptype <= 11) {
	/* Table has no entries for the slots upto setfromany */
	typePtr = &lstringTypes[ptype - 3];
    }
    return typePtr;
}

/*
 *----------------------------------------------------------------------
 *
 * NewLStringObj --
 *
 *	Creates a new lstring Obj using the string value of objv[0]
 *
 * Results:
 *	The allocated Tcl_Obj reference, with refcount 0.
 *
 * Side effects:
 *	Allocates memory.
 *
 *----------------------------------------------------------------------
 */
static Tcl_Obj *
NewLStringObj(
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const *objv)
{
    LString *lstringRepPtr;
    Tcl_ObjInternalRep itr;
    size_t repSize;
    Tcl_Obj *lstringPtr;
    const char *string;
    static const char* procTypeNames[] = {
	"FREEREP", "DUPREP", "UPDATESTRING", "SETFROMANY",
	"LENGTH", "INDEX", "SLICE", "REVERSE", "GETELEMENTS",
	"SETELEMENT", "REPLACE", NULL
    };
    int i = 0;
    int ptype;
    const Tcl_ObjType *lstringTypePtr = &lstringTypes[10];

    repSize = sizeof(LString);
    lstringRepPtr = (LString*)Tcl_Alloc(repSize);

    while (i<objc) {
	const char *s = Tcl_GetString(objv[i]);
	if (strcmp(s, "-not") == 0) {
	    i++;
	    if (Tcl_GetIndexFromObj(interp, objv[i], procTypeNames, "proctype", 0, &ptype)==TCL_OK) {
		lstringTypePtr = GetLStringType(ptype);
	    }
	} else if (strcmp(s, "--") == 0) {
	    // End of options
	    i++;
	    break;
	} else {
	    break;
	}
	i++;
    }
    if (i != objc-1) {
	Tcl_Free((char*)lstringRepPtr);
	Tcl_WrongNumArgs(interp, 0, objv, "lstring string");
	return NULL;
    }
    string = Tcl_GetString(objv[i]);

    lstringRepPtr->strlen = strlen(string);
    lstringRepPtr->allocated = lstringRepPtr->strlen + 1;
    lstringRepPtr->string = (char*)Tcl_Alloc(lstringRepPtr->allocated);
    strcpy(lstringRepPtr->string, string);
    lstringRepPtr->elements = NULL;
    lstringPtr = Tcl_NewObj();
    itr.twoPtrValue.ptr1 = lstringRepPtr;
    itr.twoPtrValue.ptr2 = NULL;
    Tcl_StoreInternalRep(lstringPtr, lstringTypePtr, &itr);
    if (lstringRepPtr->strlen > 0) {
	Tcl_InvalidateStringRep(lstringPtr);
    } else {
	Tcl_InitStringRep(lstringPtr, NULL, 0);
    }
    return lstringPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * LStringFreeElements --
 *
 *	Free the element array
 *
 *----------------------------------------------------------------------
 */
static void
LStringFreeElements(
    Tcl_Obj *lstringObj)
{
    LString *lstringRepPtr = (LString *)lstringObj->internalRep.twoPtrValue.ptr1;
    if (lstringRepPtr->elements) {
	Tcl_Obj **objptr = lstringRepPtr->elements;
	while (objptr < &lstringRepPtr->elements[lstringRepPtr->strlen]) {
	    Tcl_DecrRefCount(*objptr++);
	}
	Tcl_Free((char *)lstringRepPtr->elements);
	lstringRepPtr->elements = NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * LStringFreeRep --
 *
 *	Free the value storage of the lstring Obj.
 *
 * Results:
 *	void
 *
 * Side effects:
 *	Memory free'd.
 *
 *----------------------------------------------------------------------
 */
static void
LStringFreeRep(
    Tcl_Obj *lstringObj)
{
    LString *lstringRepPtr = (LString *)lstringObj->internalRep.twoPtrValue.ptr1;
    if (lstringRepPtr->string) {
	Tcl_Free(lstringRepPtr->string);
    }
    LStringFreeElements(lstringObj);
    Tcl_Free((char*)lstringRepPtr);
    lstringObj->internalRep.twoPtrValue.ptr1 = NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * LStringGetElements --
 *
 *	Get the elements of the list in an array.
 *
 * Results:
 *	objc, objv return values
 *
 * Side effects:
 *	A Tcl_Obj is stored for every element of the abstract list
 *
 *----------------------------------------------------------------------
 */
static int
LStringGetElements(
    Tcl_Interp *interp,
    Tcl_Obj *lstringObj,
    Tcl_Size *objcptr,
    Tcl_Obj ***objvptr)
{
    LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;
    Tcl_Obj **objPtr;
    char *cptr = lstringRepPtr->string;
    (void)interp;
    if (lstringRepPtr->strlen == 0) {
	*objcptr = 0;
	*objvptr = NULL;
	return TCL_OK;
    }
    if (lstringRepPtr->elements == NULL) {
	lstringRepPtr->elements = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * lstringRepPtr->strlen);
	objPtr=lstringRepPtr->elements;
	while (objPtr < &lstringRepPtr->elements[lstringRepPtr->strlen]) {
	    *objPtr = Tcl_NewStringObj(cptr++,1);
	    Tcl_IncrRefCount(*objPtr++);
	}
    }
    *objvptr = lstringRepPtr->elements;
    *objcptr = lstringRepPtr->strlen;
    return TCL_OK;
}

/*
 * UpdateStringRep
 */
static void
LStringUpdateString(
    Tcl_Obj *objPtr)
{
#   define LOCAL_SIZE 64
    int localFlags[LOCAL_SIZE], *flagPtr = NULL;
    Tcl_ObjType const *typePtr = objPtr->typePtr;
    char *p;
    Tcl_Size bytesNeeded = 0;
    Tcl_Size llen, i;

    /*
     * Handle empty list case first, so rest of the routine is simpler.
     */
    llen = typePtr->lengthProc(objPtr);
    if (llen <= 0) {
	Tcl_InitStringRep(objPtr, NULL, 0);
	return;
    }

    /*
     * Pass 1: estimate space.
     */
    if (llen <= LOCAL_SIZE) {
	flagPtr = localFlags;
    } else {
	/* We know numElems <= LIST_MAX, so this is safe. */
	flagPtr = (int *) Tcl_Alloc(llen*sizeof(int));
    }
    for (bytesNeeded = 0, i = 0; i < llen; i++) {
	Tcl_Obj *elemObj;
	const char *elemStr;
	Tcl_Size elemLen;
	flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
	typePtr->indexProc(NULL, objPtr, i, &elemObj);
	Tcl_IncrRefCount(elemObj);
	elemStr = Tcl_GetStringFromObj(elemObj, &elemLen);
	/* Note TclScanElement updates flagPtr[i] */
	bytesNeeded += Tcl_ScanCountedElement(elemStr, elemLen, &flagPtr[i]);
	if (bytesNeeded < 0) {
	    Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
	}
	Tcl_DecrRefCount(elemObj);
    }
    if (bytesNeeded > INT_MAX - llen + 1) {
	Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
    }
    bytesNeeded += llen; /* Separating spaces and terminating nul */

    /*
     * Pass 2: generate the string repr.
     */
    objPtr->bytes = (char *) Tcl_Alloc(bytesNeeded);
    p = objPtr->bytes;
    for (i = 0; i < llen; i++) {
	Tcl_Obj *elemObj;
	const char *elemStr;
	Tcl_Size elemLen;
	flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
	typePtr->indexProc(NULL, objPtr, i, &elemObj);
	Tcl_IncrRefCount(elemObj);
	elemStr = Tcl_GetStringFromObj(elemObj, &elemLen);
	p += Tcl_ConvertCountedElement(elemStr, elemLen, p, flagPtr[i]);
	*p++ = ' ';
	Tcl_DecrRefCount(elemObj);
    }
    p[-1] = '\0'; /* Overwrite last space added */

    /* Length of generated string */
    objPtr->length = p - 1 - objPtr->bytes;

    if (flagPtr != localFlags) {
	Tcl_Free(flagPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * LStringObjCmd --
 *
 *	Script level command that creats an lstring Obj value.
 *
 * Results:
 *	Returns and lstring Obj value in the interp results.
 *
 * Side effects:
 *	Interp results modified.
 *
 *----------------------------------------------------------------------
 */
static int
LStringObjCmd(
    void *clientData,
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *lstringObj;

    (void)clientData;
    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "string");
	return TCL_ERROR;
    }

    lstringObj = NewLStringObj(interp, objc-1, &objv[1]);

    if (lstringObj) {
	Tcl_SetObjResult(interp, lstringObj);
	return TCL_OK;
    }
    return TCL_ERROR;
}

/*
 * lgen - Derived from TIP 192 - Lazy Lists
 * Generate a list using a command provided as argument(s).
 * The command computes the value for a given index.
 */

/*
 *----------------------------------------------------------------------
 *
 * LgenSeriesGenerateIndex --
 *
 *	Evaluate the generation function.
 *	The provided funtion computes the value for a give index.
 *
 * Returns:
 *	The value for a given index, or NULL if that doesn't exist
 *	or there is otherwise an error.
 *
 * Side effects:
 *	Calls back recursively into Tcl, so has unbounded side effects.
 *
 *----------------------------------------------------------------------
 */
static Tcl_Obj *
LgenSeriesGenerateIndex(
    Tcl_Obj *objPtr,
    Tcl_Size index)
{
    LgenSeries *lgenSeriesPtr = (LgenSeries *)objPtr->internalRep.twoPtrValue.ptr1;
    Tcl_Obj *elemObj = NULL;
    Tcl_Interp *intrp = lgenSeriesPtr->interp;
    Tcl_Obj *genCmd = lgenSeriesPtr->genFnObj;
    Tcl_Size endidx = lgenSeriesPtr->nargs-1;

    if (0 <= index && index < lgenSeriesPtr->len) {
	Tcl_Obj *indexObj = Tcl_NewWideIntObj(index);
	Tcl_ListObjReplace(intrp, genCmd, endidx, 1, 1, &indexObj);
	// EVAL DIRECT to avoid interfering with bytecode compile which may be
	// active on the stack
	int flags = TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT;
	int status = Tcl_EvalObjEx(intrp, genCmd, flags);
	elemObj = Tcl_GetObjResult(intrp);
	if (status != TCL_OK) {
	    Tcl_SetObjResult(intrp, Tcl_ObjPrintf(
		    "Error: %s\nwhile executing %s\n",
		    elemObj ? Tcl_GetString(elemObj) : "NULL",
		    Tcl_GetString(genCmd)));
	    return NULL;
	}
    }
    return elemObj;
}

/*
 * Abstract List Length function
 */
static Tcl_Size
LgenSeriesLength(
    Tcl_Obj *objPtr)
{
    LgenSeries *lgenSeriesRepPtr = (LgenSeries *)
	    objPtr->internalRep.twoPtrValue.ptr1;
    return lgenSeriesRepPtr->len;
}

/*
 * Abstract List Index function
 */
static int
LgenSeriesIndex(
    Tcl_Interp *interp,
    Tcl_Obj *lgenSeriesObjPtr,
    Tcl_Size index,
    Tcl_Obj **elemPtr)
{
    LgenSeries *lgenSeriesRepPtr;
    Tcl_Obj *element;

    lgenSeriesRepPtr = (LgenSeries*)
	    lgenSeriesObjPtr->internalRep.twoPtrValue.ptr1;

    if (index < 0 || index >= lgenSeriesRepPtr->len) {
	*elemPtr = NULL;
	return TCL_OK;
    }
    if (lgenSeriesRepPtr->interp == NULL && interp == NULL) {
	return TCL_ERROR;
    }

    lgenSeriesRepPtr->interp = interp;

    element = LgenSeriesGenerateIndex(lgenSeriesObjPtr, index);
    if (element) {
	*elemPtr = element;
    } else {
	return TCL_ERROR;
    }

    return TCL_OK;
}

/*
 * UpdateStringRep
 */
static void
LgenSeriesUpdateString(
    Tcl_Obj *objPtr)
{
    LgenSeries *lgenSeriesRepPtr;
    Tcl_Obj *element;
    Tcl_Size i;
    Tcl_Size bytlen;
    Tcl_Obj *tmpstr = Tcl_NewObj();

    lgenSeriesRepPtr = (LgenSeries*)objPtr->internalRep.twoPtrValue.ptr1;

    for (i=0, bytlen=0; i<lgenSeriesRepPtr->len; i++) {
	element = LgenSeriesGenerateIndex(objPtr, i);
	if (element) {
	    if (i) {
		Tcl_AppendToObj(tmpstr," ",1);
	    }
	    Tcl_AppendObjToObj(tmpstr,element);
	}
    }

    char *str = Tcl_GetStringFromObj(tmpstr, &bytlen);

    TclOOM(Tcl_InitStringRep(objPtr, str, bytlen), bytlen+1);
    Tcl_DecrRefCount(tmpstr);
}

/*
 * ObjType Free Internal Rep function
 */
static void
LgenSeriesFreeIntRep(
    Tcl_Obj *objPtr)
{
    LgenSeries *lgenSeries = (LgenSeries*)objPtr->internalRep.twoPtrValue.ptr1;
    if (lgenSeries->genFnObj) {
	Tcl_DecrRefCount(lgenSeries->genFnObj);
    }
    lgenSeries->interp = NULL;
    Tcl_Free(lgenSeries);
    objPtr->internalRep.twoPtrValue.ptr1 = 0;
}

/*
 * ObjType Duplicate Internal Rep Function
 */
static void
LgenSeriesDupIntRep(
    Tcl_Obj *srcPtr,
    Tcl_Obj *copyPtr)
{
    LgenSeries *srcLgenSeries = (LgenSeries*)srcPtr->internalRep.twoPtrValue.ptr1;
    Tcl_Size repSize = sizeof(LgenSeries);
    LgenSeries *copyLgenSeries = (LgenSeries*)Tcl_Alloc(repSize);

    copyLgenSeries->interp = srcLgenSeries->interp;
    copyLgenSeries->nargs = srcLgenSeries->nargs;
    copyLgenSeries->len = srcLgenSeries->len;
    copyLgenSeries->genFnObj = Tcl_DuplicateObj(srcLgenSeries->genFnObj);
    Tcl_IncrRefCount(copyLgenSeries->genFnObj);
    copyPtr->typePtr = &lgenSeriesType;
    copyPtr->internalRep.twoPtrValue.ptr1 = copyLgenSeries;
    copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
}

/*
 * Create a new lgenseries Tcl_Obj
 */
static Tcl_Obj *
NewLgenSeriesObj(
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const *objv)
{
    Tcl_WideInt length;
    LgenSeries *lGenSeriesRepPtr;
    Tcl_Obj *lGenSeriesObj;

    if (objc < 2) {
	return NULL;
    }

    if (Tcl_GetWideIntFromObj(NULL, objv[0], &length) != TCL_OK
	    || length < 0) {
	return NULL;
    }

    lGenSeriesObj = Tcl_NewObj();
    lGenSeriesRepPtr = (LgenSeries*)Tcl_Alloc(sizeof(LgenSeries));
    lGenSeriesRepPtr->interp = interp; //Tcl_CreateInterp();
    lGenSeriesRepPtr->len = length;

    // Allocate array of *obj for cmd + index + args
    // objv  length cmd arg1 arg2 arg3 ...
    // argsv         0   1    2    3   ... index

    lGenSeriesRepPtr->nargs = objc;
    lGenSeriesRepPtr->genFnObj = Tcl_NewListObj(objc-1, objv+1);
    // Addd 0 placeholder for index
    Tcl_ListObjAppendElement(interp, lGenSeriesRepPtr->genFnObj, Tcl_NewIntObj(0));
    Tcl_IncrRefCount(lGenSeriesRepPtr->genFnObj);
    lGenSeriesObj->internalRep.twoPtrValue.ptr1 = lGenSeriesRepPtr;
    lGenSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
    lGenSeriesObj->typePtr = &lgenSeriesType;

    if (length > 0) {
	Tcl_InvalidateStringRep(lGenSeriesObj);
    } else {
	Tcl_InitStringRep(lGenSeriesObj, NULL, 0);
    }
    return lGenSeriesObj;
}

/*
 * The [lgen] command
 */
static int
LgenObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj *genObj = NewLgenSeriesObj(interp, objc-1, &objv[1]);
    if (genObj) {
	Tcl_SetObjResult(interp, genObj);
	return TCL_OK;
    }
    Tcl_WrongNumArgs(interp, 1, objv, "length cmd ?args?");
    return TCL_ERROR;
}

/*
 * lgen package init
 */
int
Lgen_Init(
    Tcl_Interp *interp)
{
    if (Tcl_InitStubs(interp, "9.0-", 0) == NULL) {
	return TCL_ERROR;
    }
    Tcl_CreateObjCommand2(interp, "lgen", LgenObjCmd, NULL, NULL);
    Tcl_PkgProvide(interp, "lgen", "1.0");
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ABSListTest_Init --
 *
 *	Provides Abstract List implemenations via new commands
 *
 * lstring command
 * Usage:
 *      lstring /string/
 *
 * Description:
 *	Creates a list where each character in the string is treated as an
 *	element. The string is kept as a string, not an actual list. Indexing
 *	is done by char.
 *
 * lgen command
 * Usage:
 *      lgen /length/ /cmd/ ?args...?
 *
 *	The /cmd/ should take the last argument as the index value, and return
 *	a value for that element.
 *
 * Results:
 *	The commands listed above are added to the interp.
 *
 * Side effects:
 *	New commands defined.
 *
 *----------------------------------------------------------------------
 */
int
Tcl_ABSListTest_Init(
    Tcl_Interp *interp)
{
    if (Tcl_InitStubs(interp, "9.0-", 0) == NULL) {
	return TCL_ERROR;
    }
    Tcl_CreateObjCommand2(interp, "lstring", LStringObjCmd, NULL, NULL);
    Tcl_CreateObjCommand2(interp, "lgen", LgenObjCmd, NULL, NULL);
    Tcl_PkgProvide(interp, "abstractlisttest", "1.0.0");
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */
