Tcl Source Code

#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: tclInt.decls,v 1.112 2007/08/04 18:32:27 msofer Exp $

library tcl

# Define the unsupported generic interfaces.

interface tclInt

declare 232 generic {
    int TclEvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags,
	    const CmdFrame *invoker, int word)
}
declare 233 generic {
    void TclGetSrcInfoForPc(CmdFrame *contextPtr)
}

# Exports for VarReform compat: Itcl likes to peek into our varTables :(
declare 234 generic {
    Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key, 
             int *newPtr)
}

##############################################################################

# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.

interface tclIntPlat

 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.328 2007/08/04 18:32:27 msofer Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options

 */

typedef struct TclVarHashTable {
    Tcl_HashTable table;
    struct Namespace *nsPtr;
} TclVarHashTable;

/*
 * This is for itcl - it likes to search our varTables directly :(
 */

#define TclVarHashFindVar(tablePtr, key) \
    TclVarHashCreateVar((tablePtr), (key), NULL)


/*
 * The structure below defines a namespace.
 * Note: the first five fields must match exactly the fields in a
 * Tcl_Namespace structure (see tcl.h). If you change one, be sure to change
 * the other.
 */

#define VAR_ARRAY		0x1
#define VAR_LINK		0x2

/* Type of storage (0 is compiled local) */
#define VAR_IN_HASHTABLE	0x4
#define VAR_DEAD_HASH           0x8
#define VAR_ARRAY_ELEMENT	0x1000
#define VAR_NAMESPACE_VAR	0x80      /* KEEP OLD VALUE for Itcl */

#define VAR_ALL_HASH (VAR_IN_HASHTABLE|VAR_DEAD_HASH|VAR_NAMESPACE_VAR|VAR_ARRAY_ELEMENT)

/* Trace and search state */

#define VAR_TRACED_READ        0x10       /* TCL_TRACE_READS  */
#define VAR_TRACED_WRITE       0x20       /* TCL_TRACE_WRITES */
#define VAR_TRACED_UNSET       0x40       /* TCL_TRACE_UNSETS */
#define VAR_TRACED_ARRAY       0x800      /* TCL_TRACE_ARRAY  */
#define VAR_TRACE_ACTIVE       0x2000
#define VAR_SEARCH_ACTIVE      0x4000
#define VAR_ALL_TRACES \
   (VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_ARRAY|VAR_TRACED_UNSET)


/* Special handling on initialisation (only CompiledLocal) */
#define VAR_ARGUMENT		0x100     /* KEEP OLD VALUE! See tclProc.c */

#define TclSetVarTraceActive(varPtr) \
    (varPtr)->flags |= VAR_TRACE_ACTIVE

#define TclClearVarTraceActive(varPtr) \
    (varPtr)->flags &= ~VAR_TRACE_ACTIVE

#define TclSetVarNamespaceVar(varPtr) \

    (varPtr)->flags |= VAR_NAMESPACE_VAR;\
    ((VarInHash *)(varPtr))->refCount++


#define TclClearVarNamespaceVar(varPtr) \
    if (TclIsVarNamespaceVar(varPtr)) {\
        (varPtr)->flags &= ~VAR_NAMESPACE_VAR;\
        ((VarInHash *)(varPtr))->refCount--;\
    }

/*
 * tclIntDecls.h --
 *
 *	This file contains the declarations for all unsupported
 *	functions that are exported by the Tcl library.  These
 *	interfaces are not guaranteed to remain the same between
 *	versions.  Use at your own risk.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIntDecls.h,v 1.103 2007/08/04 18:32:27 msofer Exp $
 */

#ifndef _TCLINTDECLS
#define _TCLINTDECLS

#include "tclPort.h"

				int word);
#endif
#ifndef TclGetSrcInfoForPc_TCL_DECLARED
#define TclGetSrcInfoForPc_TCL_DECLARED
/* 233 */
EXTERN void		TclGetSrcInfoForPc (CmdFrame * contextPtr);
#endif
#ifndef TclVarHashCreateVar_TCL_DECLARED
#define TclVarHashCreateVar_TCL_DECLARED
/* 234 */
EXTERN Var *		TclVarHashCreateVar (TclVarHashTable * tablePtr, 
				const char * key, int * newPtr);
#endif

typedef struct TclIntStubs {
    int magic;
    struct TclIntStubHooks *hooks;

    void *reserved0;
    void *reserved1;

    void (*tclSetNsPath) (Namespace * nsPtr, int pathLength, Tcl_Namespace * pathAry[]); /* 227 */
    int (*tclObjInterpProcCore) (register Tcl_Interp * interp, Tcl_Obj * procNameObj, int skip, ProcErrorProc errorProc); /* 228 */
    int (*tclPtrMakeUpvar) (Tcl_Interp * interp, Var * otherP1Ptr, CONST char * myName, int myFlags, int index); /* 229 */
    Var * (*tclObjLookupVar) (Tcl_Interp * interp, Tcl_Obj * part1Ptr, CONST char * part2, int flags, CONST char * msg, CONST int createPart1, CONST int createPart2, Var ** arrayPtrPtr); /* 230 */
    int (*tclGetNamespaceFromObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Namespace ** nsPtrPtr); /* 231 */
    int (*tclEvalObjEx) (Tcl_Interp * interp, Tcl_Obj * objPtr, int flags, const CmdFrame * invoker, int word); /* 232 */
    void (*tclGetSrcInfoForPc) (CmdFrame * contextPtr); /* 233 */
    Var * (*tclVarHashCreateVar) (TclVarHashTable * tablePtr, const char * key, int * newPtr); /* 234 */
} TclIntStubs;

#ifdef __cplusplus
extern "C" {
#endif
extern TclIntStubs *tclIntStubsPtr;
#ifdef __cplusplus

#define TclEvalObjEx \
	(tclIntStubsPtr->tclEvalObjEx) /* 232 */
#endif
#ifndef TclGetSrcInfoForPc
#define TclGetSrcInfoForPc \
	(tclIntStubsPtr->tclGetSrcInfoForPc) /* 233 */
#endif
#ifndef TclVarHashCreateVar
#define TclVarHashCreateVar \
	(tclIntStubsPtr->tclVarHashCreateVar) /* 234 */
#endif

#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

/* !END!: Do not edit above this line. */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT

#endif /* _TCLINTDECLS */

/*
 * tclProc.c --
 *
 *	This file contains routines that implement Tcl procedures, including
 *	the "proc" and "uplevel" commands.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 2004-2006 Miguel Sofer
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclProc.c,v 1.127 2007/08/04 18:32:27 msofer Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Prototypes for static functions in this file

    ByteCode *codePtr;

    bodyPtr = framePtr->procPtr->bodyPtr;
    if (bodyPtr->typePtr != &tclByteCodeType) {
	Tcl_Panic("body object for proc attached to frame is not a byte code type");
    }
    codePtr = bodyPtr->internalRep.otherValuePtr;

    if (framePtr->numCompiledLocals) {
	if (!codePtr->localCachePtr) {
	    InitLocalCache(framePtr->procPtr) ;
	}
	framePtr->localCachePtr = codePtr->localCachePtr;
	framePtr->localCachePtr->refCount++;
    }    

    InitCompiledLocals(interp, codePtr, varPtr, nsPtr);
}

/*
 *----------------------------------------------------------------------
 *

/* 
 * tclStubInit.c --
 *
 *	This file contains the initializers for the Tcl stub vectors.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStubInit.c,v 1.142 2007/08/04 18:32:28 msofer Exp $
 */

#include "tclInt.h"
#include "tommath.h"

/*
 * Remove macros that will interfere with the definitions below.

    TclSetNsPath, /* 227 */
    TclObjInterpProcCore, /* 228 */
    TclPtrMakeUpvar, /* 229 */
    TclObjLookupVar, /* 230 */
    TclGetNamespaceFromObj, /* 231 */
    TclEvalObjEx, /* 232 */
    TclGetSrcInfoForPc, /* 233 */
    TclVarHashCreateVar, /* 234 */
};

TclIntPlatStubs tclIntPlatStubs = {
    TCL_STUB_MAGIC,
    NULL,
#if !defined(__WIN32__) /* UNIX */
    TclGetAndDetachPids, /* 0 */

 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
 * Copyright (c) 2007 Miguel Sofer
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclVar.c,v 1.149 2007/08/04 18:32:28 msofer Exp $
 */

#include "tclInt.h"

/*
 * Prototypes for the variable hash key methods.
 */

 * as this can be safely copied.
 */

Tcl_ObjType tclArraySearchType = {
    "array search",
    NULL, NULL, NULL, SetArraySearchObj
};

Var *
TclVarHashCreateVar(
    TclVarHashTable *tablePtr,
    const char *key, 
    int *newPtr)
{
    Tcl_Obj *keyPtr;
    Var *varPtr;

    keyPtr = Tcl_NewStringObj(key, -1);
    Tcl_IncrRefCount(keyPtr);
    varPtr = VarHashCreateVar(tablePtr, keyPtr, newPtr);
    Tcl_DecrRefCount(keyPtr);

    return varPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCleanupVar --
 *
 *	This function is called when it looks like it may be OK to free up a

		Tcl_SetHashValue(tPtr, tracePtr);
	    } else {
		tPtr = NULL;
	    }
	}

	if ((dummyVar.flags & VAR_TRACED_UNSET)
		|| (arrayPtr && (arrayPtr->flags & VAR_TRACED_UNSET))) {
	    dummyVar.flags &= ~VAR_TRACE_ACTIVE;
	    TclObjCallVarTraces(iPtr, arrayPtr, (Var *) &dummyVar,
		    part1Ptr, part2Ptr,
		    (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))| TCL_TRACE_UNSETS,
		    /* leaveErrMsg */ 0, -1);
	    if (tPtr) {
		Tcl_DeleteHashEntry(tPtr);