tclvar.c

CMX990 demonstration board (DE9901)

    for (i = 2; i < argc; i++) {
	result = Tcl_SetVar(interp, argv[1], argv[i],
		TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG);
	if (result == NULL) {
	    return TCL_ERROR;
	}
    }
    interp->result = result;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LappendCmd --
 *
 *	This procedure is invoked to process the "lappend" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result value.
 *
 * Side effects:
 *	A variable's value may be changed.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_LappendCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    register Tcl_Interp *interp;	/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int i;
    char *result = NULL;		/* (Initialization only needed to keep
					 * the compiler from complaining) */

    if (argc < 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		argv[0], " varName value ?value ...?\"", (char *) NULL);
	return TCL_ERROR;
    }

    for (i = 2; i < argc; i++) {
	result = Tcl_SetVar(interp, argv[1], argv[i],
		TCL_APPEND_VALUE|TCL_LIST_ELEMENT|TCL_LEAVE_ERR_MSG);
	if (result == NULL) {
	    return TCL_ERROR;
	}
    }
    interp->result = result;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ArrayCmd --
 *
 *	This procedure is invoked to process the "array" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result value.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_ArrayCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    register Tcl_Interp *interp;	/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int length;
    char c;
    Var *varPtr;
    Tcl_HashEntry *hPtr;
    Interp *iPtr = (Interp *) interp;

    if (argc < 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		argv[0], " option arrayName ?arg ...?\"", (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Locate the array variable (and it better be an array).
     */

    if (iPtr->varFramePtr == NULL) {
	hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
    } else {
	hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
    }
    if (hPtr == NULL) {
	notArray:
	Tcl_AppendResult(interp, "\"", argv[2], "\" isn't an array",
		(char *) NULL);
	return TCL_ERROR;
    }
    varPtr = (Var *) Tcl_GetHashValue(hPtr);
    if (varPtr->flags & VAR_UPVAR) {
	varPtr = (Var *) Tcl_GetHashValue(varPtr->value.upvarPtr);
    }
    if (!(varPtr->flags & VAR_ARRAY)) {
	goto notArray;
    }

    /*
     * Dispatch based on the option.
     */

    c = argv[1][0];
    length = strlen(argv[1]);
    if ((c == 'a') && (strncmp(argv[1], "anymore", length) == 0)) {
	ArraySearch *searchPtr;

	if (argc != 4) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " anymore arrayName searchId\"", (char *) NULL);
	    return TCL_ERROR;
	}
	searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
	if (searchPtr == NULL) {
	    return TCL_ERROR;
	}
	while (1) {
	    Var *varPtr2;

	    if (searchPtr->nextEntry != NULL) {
		varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
		if (!(varPtr2->flags & VAR_UNDEFINED)) {
		    break;
		}
	    }
	    searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
	    if (searchPtr->nextEntry == NULL) {
		interp->result = "0";
		return TCL_OK;
	    }
	}
	interp->result = "1";
	return TCL_OK;
    } else if ((c == 'd') && (strncmp(argv[1], "donesearch", length) == 0)) {
	ArraySearch *searchPtr, *prevPtr;

	if (argc != 4) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " donesearch arrayName searchId\"", (char *) NULL);
	    return TCL_ERROR;
	}
	searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
	if (searchPtr == NULL) {
	    return TCL_ERROR;
	}
	if (varPtr->searchPtr == searchPtr) {
	    varPtr->searchPtr = searchPtr->nextPtr;
	} else {
	    for (prevPtr = varPtr->searchPtr; ; prevPtr = prevPtr->nextPtr) {
		if (prevPtr->nextPtr == searchPtr) {
		    prevPtr->nextPtr = searchPtr->nextPtr;
		    break;
		}
	    }
	}
	ckfree((char *) searchPtr);
    } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)
	    && (length >= 2)) {
	Tcl_HashSearch search;
	Var *varPtr2;

	if (argc != 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " names arrayName\"", (char *) NULL);
	    return TCL_ERROR;
	}
	for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
		hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	    varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
	    if (varPtr2->flags & VAR_UNDEFINED) {
		continue;
	    }
	    Tcl_AppendElement(interp,
		    Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), 0);
	}
    } else if ((c == 'n') && (strncmp(argv[1], "nextelement", length) == 0)
	    && (length >= 2)) {
	ArraySearch *searchPtr;
	Tcl_HashEntry *hPtr;

	if (argc != 4) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " nextelement arrayName searchId\"",
		    (char *) NULL);
	    return TCL_ERROR;
	}
	searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
	if (searchPtr == NULL) {
	    return TCL_ERROR;
	}
	while (1) {
	    Var *varPtr2;

	    hPtr = searchPtr->nextEntry;
	    if (hPtr == NULL) {
		hPtr = Tcl_NextHashEntry(&searchPtr->search);
		if (hPtr == NULL) {
		    return TCL_OK;
		}
	    } else {
		searchPtr->nextEntry = NULL;
	    }
	    varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
	    if (!(varPtr2->flags & VAR_UNDEFINED)) {
		break;
	    }
	}
	interp->result = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
    } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)
	    && (length >= 2)) {
	Tcl_HashSearch search;
	Var *varPtr2;
	int size;

	if (argc != 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " size arrayName\"", (char *) NULL);
	    return TCL_ERROR;
	}
	size = 0;
	for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
		hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	    varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
	    if (varPtr2->flags & VAR_UNDEFINED) {
		continue;
	    }
	    size++;
	}
	sprintf(interp->result, "%d", size);
    } else if ((c == 's') && (strncmp(argv[1], "startsearch", length) == 0)
	    && (length >= 2)) {
	ArraySearch *searchPtr;

	if (argc != 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " startsearch arrayName\"", (char *) NULL);
	    return TCL_ERROR;
	}
	searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
	if (varPtr->searchPtr == NULL) {
	    searchPtr->id = 1;
	    Tcl_AppendResult(interp, "s-1-", argv[2], (char *) NULL);
	} else {
	    char string[20];

	    searchPtr->id = varPtr->searchPtr->id + 1;
	    sprintf(string, "%d", searchPtr->id);
	    Tcl_AppendResult(interp, "s-", string, "-", argv[2],
		    (char *) NULL);
	}
	searchPtr->varPtr = varPtr;
	searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
		&searchPtr->search);
	searchPtr->nextPtr = varPtr->searchPtr;
	varPtr->searchPtr = searchPtr;
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": should be anymore, donesearch, names, nextelement, ",
		"size, or startsearch", (char *) NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GlobalCmd --
 *
 *	This procedure is invoked to process the "global" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result value.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_GlobalCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    Var *varPtr, *gVarPtr;
    register Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hPtr, *hPtr2;
    int new;

    if (argc < 2) {
	Tcl_AppendResult((Tcl_Interp *) iPtr, "wrong # args: should be \"",
		argv[0], " varName ?varName ...?\"", (char *) NULL);
	return TCL_ERROR;
    }
    if (iPtr->varFramePtr == NULL) {
	return TCL_OK;
    }

    for (argc--, argv++; argc > 0; argc--, argv++) {
	hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, *argv, &new);
	if (new) {
	    gVarPtr = NewVar(0);
	    gVarPtr->flags |= VAR_UNDEFINED;
	    Tcl_SetHashValue(hPtr, gVarPtr);
	} else {
	    gVarPtr = (Var *) Tcl_GetHashValue(hPtr);
	}
	hPtr2 = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, *argv, &new);
	if (!new) {
	    Var *varPtr;
	    varPtr = (Var *) Tcl_GetHashValue(hPtr2);
	    if (varPtr->flags & VAR_UPVAR) {
		continue;
	    } else {
		Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", *argv,
		    "\" already exists", (char *) NULL);
		return TCL_ERROR;
	    }
	}
	varPtr = NewVar(0);
	varPtr->flags |= VAR_UPVAR;
	varPtr->value.upvarPtr = hPtr;
	gVarPtr->upvarUses++;
	Tcl_SetHashValue(hPtr2, varPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UpvarCmd --
 *
 *	This procedure is invoked to process the "upvar" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result value.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_UpvarCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    register Interp *iPtr = (Interp *) interp;
    int result;
    CallFrame *framePtr;
    Var *varPtr = NULL;
    Tcl_HashTable *upVarTablePtr;
    Tcl_HashEntry *hPtr, *hPtr2;
    int new;
    Var *upVarPtr;

    if (argc < 3) {
	upvarSyntax:
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" ?level? otherVar localVar ?otherVar localVar ...?\"",
		(char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Find the hash table containing the variable being referenced.
     */

    result = TclGetFrame(interp, argv[1], &framePtr);
    if (result == -1) {
	return TCL_ERROR;
    }
    argc -= result+1;
    argv += result+1;
    if (framePtr == NULL) {
	upVarTablePtr = &iPtr->globalTable;
    } else {
	upVarTablePtr = &framePtr->varTable;
    }

    if ((argc & 1) != 0) {
	goto upvarSyntax;
    }

    /*
     * Iterate over all the pairs of (local variable, other variable)
     * names.  For each pair, create a hash table entry in the upper
     * context (if the name wasn't there already), then associate it
     * with a new local variable.
     */

    while (argc > 0) {
        hPtr = Tcl_CreateHashEntry(upVarTablePtr, argv[0], &new);
        if (new) {
            upVarPtr = NewVar(0);
            upVarPtr->flags |= VAR_UNDEFINED;
            Tcl_SetHashValue(hPtr, upVarPtr);
        } else {
            upVarPtr = (Var *) Tcl_GetHashValue(hPtr);
	    if (upVarPtr->flags & VAR_UPVAR) {
		hPtr = upVarPtr->value.upvarPtr;
		upVarPtr = (Var *) Tcl_GetHashValue(hPtr);
	    }
        }

        hPtr2 = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable,
                    argv[1], &new);
        if (!new) {
            Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", argv[1],
                "\" already exists", (char *) NULL);
            return TCL_ERROR;
        }
        varPtr = NewVar(0);
        varPtr->flags |= VAR_UPVAR;
        varPtr->value.upvarPtr = hPtr;
        upVarPtr->upvarUses++;
        Tcl_SetHashValue(hPtr2, varPtr);

        argc -= 2;