aboutsummaryrefslogtreecommitdiffstats
path: root/contrib/tcl/generic
diff options
context:
space:
mode:
authorPoul-Henning Kamp <phk@FreeBSD.org>1997-07-25 19:27:55 +0000
committerPoul-Henning Kamp <phk@FreeBSD.org>1997-07-25 19:27:55 +0000
commit3d33409926539d866dcea9fc5cb14113b312adf0 (patch)
treed2f88b3e9ffa79ffb2cc1a0699dd3ee96c47c3e5 /contrib/tcl/generic
parent8569730d6bc2e4cb5e784997313325b13518e066 (diff)
downloadsrc-3d33409926539d866dcea9fc5cb14113b312adf0.tar.gz
src-3d33409926539d866dcea9fc5cb14113b312adf0.zip
Import TCL release 8.0 beta 2.
Notes
Notes: svn path=/vendor/tcl/dist/; revision=27676
Diffstat (limited to 'contrib/tcl/generic')
-rw-r--r--contrib/tcl/generic/panic.c10
-rw-r--r--contrib/tcl/generic/regexp.c4
-rw-r--r--contrib/tcl/generic/tcl.h701
-rw-r--r--contrib/tcl/generic/tclBasic.c3402
-rw-r--r--contrib/tcl/generic/tclBinary.c977
-rw-r--r--contrib/tcl/generic/tclCkalloc.c117
-rw-r--r--contrib/tcl/generic/tclClock.c330
-rw-r--r--contrib/tcl/generic/tclCmdAH.c1396
-rw-r--r--contrib/tcl/generic/tclCmdIL.c3138
-rw-r--r--contrib/tcl/generic/tclCmdMZ.c1280
-rw-r--r--contrib/tcl/generic/tclCompExpr.c2290
-rw-r--r--contrib/tcl/generic/tclCompile.c7464
-rw-r--r--contrib/tcl/generic/tclCompile.h950
-rw-r--r--contrib/tcl/generic/tclDate.c227
-rw-r--r--contrib/tcl/generic/tclEnv.c60
-rw-r--r--contrib/tcl/generic/tclEvent.c1731
-rw-r--r--contrib/tcl/generic/tclExecute.c4660
-rw-r--r--contrib/tcl/generic/tclFCmd.c815
-rw-r--r--contrib/tcl/generic/tclFileName.c49
-rw-r--r--contrib/tcl/generic/tclGet.c112
-rw-r--r--contrib/tcl/generic/tclGetDate.y239
-rw-r--r--contrib/tcl/generic/tclHash.c44
-rw-r--r--contrib/tcl/generic/tclHistory.c14
-rw-r--r--contrib/tcl/generic/tclIO.c2534
-rw-r--r--contrib/tcl/generic/tclIOCmd.c513
-rw-r--r--contrib/tcl/generic/tclIOSock.c28
-rw-r--r--contrib/tcl/generic/tclIOUtil.c917
-rw-r--r--contrib/tcl/generic/tclIndexObj.c239
-rw-r--r--contrib/tcl/generic/tclInt.h1625
-rw-r--r--contrib/tcl/generic/tclInterp.c3048
-rw-r--r--contrib/tcl/generic/tclLink.c47
-rw-r--r--contrib/tcl/generic/tclListObj.c1053
-rw-r--r--contrib/tcl/generic/tclLoad.c111
-rw-r--r--contrib/tcl/generic/tclLoadNone.c7
-rw-r--r--contrib/tcl/generic/tclMain.c40
-rw-r--r--contrib/tcl/generic/tclNamesp.c3770
-rw-r--r--contrib/tcl/generic/tclNotify.c561
-rw-r--r--contrib/tcl/generic/tclObj.c2021
-rw-r--r--contrib/tcl/generic/tclParse.c612
-rw-r--r--contrib/tcl/generic/tclPipe.c1051
-rw-r--r--contrib/tcl/generic/tclPkg.c22
-rw-r--r--contrib/tcl/generic/tclPosixStr.c4
-rw-r--r--contrib/tcl/generic/tclPreserve.c2
-rw-r--r--contrib/tcl/generic/tclProc.c721
-rw-r--r--contrib/tcl/generic/tclStringObj.c598
-rw-r--r--contrib/tcl/generic/tclTest.c1173
-rw-r--r--contrib/tcl/generic/tclTestObj.c1097
-rw-r--r--contrib/tcl/generic/tclTimer.c1081
-rw-r--r--contrib/tcl/generic/tclUtil.c1193
-rw-r--r--contrib/tcl/generic/tclVar.c3487
50 files changed, 46975 insertions, 10590 deletions
diff --git a/contrib/tcl/generic/panic.c b/contrib/tcl/generic/panic.c
index 4ad98fd06573..420a15729147 100644
--- a/contrib/tcl/generic/panic.c
+++ b/contrib/tcl/generic/panic.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) panic.c 1.11 96/02/15 11:50:29
+ * SCCS: @(#) panic.c 1.15 96/09/12 14:55:25
*/
#include <stdio.h>
@@ -21,7 +21,13 @@
# include <stdlib.h>
#endif
+#define panic panicDummy
#include "tcl.h"
+#undef panic
+
+EXTERN void panic _ANSI_ARGS_((char *format, char *arg1,
+ char *arg2, char *arg3, char *arg4, char *arg5,
+ char *arg6, char *arg7, char *arg8));
/*
* The panicProc variable contains a pointer to an application
@@ -29,8 +35,6 @@
*/
void (*panicProc) _ANSI_ARGS_(TCL_VARARGS(char *,format)) = NULL;
-
-
/*
*----------------------------------------------------------------------
diff --git a/contrib/tcl/generic/regexp.c b/contrib/tcl/generic/regexp.c
index 52e5a51e2d52..825483674acf 100644
--- a/contrib/tcl/generic/regexp.c
+++ b/contrib/tcl/generic/regexp.c
@@ -41,7 +41,7 @@
* *** 2. This in addition to changes to TclRegError makes the ***
* *** code multi-thread safe. ***
*
- * SCCS: @(#) regexp.c 1.12 96/04/02 13:54:57
+ * SCCS: @(#) regexp.c 1.13 97/04/29 17:49:17
*/
#include "tclInt.h"
@@ -569,13 +569,11 @@ struct regcomp_state *rcstate;
case ')':
FAIL("internal urp"); /* Supposed to be caught earlier. */
/* NOTREACHED */
- break;
case '?':
case '+':
case '*':
FAIL("?+* follows nothing");
/* NOTREACHED */
- break;
case '\\':
if (*rcstate->regparse == '\0')
FAIL("trailing \\");
diff --git a/contrib/tcl/generic/tcl.h b/contrib/tcl/generic/tcl.h
index 37490ba231cc..22331af4e955 100644
--- a/contrib/tcl/generic/tcl.h
+++ b/contrib/tcl/generic/tcl.h
@@ -5,18 +5,45 @@
* of the Tcl interpreter.
*
* Copyright (c) 1987-1994 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1993-1996 Lucent Technologies.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tcl.h 1.269 96/06/13 16:36:48
+ * SCCS: @(#) tcl.h 1.318 97/06/26 13:43:02
*/
#ifndef _TCL
#define _TCL
/*
+ * When version numbers change here, must also go into the following files
+ * and update the version numbers:
+ *
+ * library/init.tcl
+ * unix/configure.in
+ * unix/pkginfo
+ * win/makefile.bc
+ * win/makefile.vc
+ *
+ * The release level should be 0 for alpha, 1 for beta, and 2 for
+ * final/patch. The release serial value is the number that follows the
+ * "a", "b", or "p" in the patch level; for example, if the patch level
+ * is 7.6b2, TCL_RELEASE_SERIAL is 2. It restarts at 1 whenever the
+ * release level is changed, except for the final release which is 0
+ * (the first patch will start at 1).
+ */
+
+#define TCL_MAJOR_VERSION 8
+#define TCL_MINOR_VERSION 0
+#define TCL_RELEASE_LEVEL 1
+#define TCL_RELEASE_SERIAL 2
+
+#define TCL_VERSION "8.0"
+#define TCL_PATCH_LEVEL "8.0b2"
+
+/*
* The following definitions set up the proper options for Windows
* compilers. We use this method because there is no autoconf equivalent.
*/
@@ -28,6 +55,9 @@
#endif
#ifdef __WIN32__
+# ifndef STRICT
+# define STRICT
+# endif
# ifndef USE_PROTOTYPE
# define USE_PROTOTYPE 1
# endif
@@ -40,16 +70,42 @@
# ifndef USE_TCLALLOC
# define USE_TCLALLOC 1
# endif
+# ifndef STRINGIFY
+# define STRINGIFY(x) STRINGIFY1(x)
+# define STRINGIFY1(x) #x
+# endif
#endif /* __WIN32__ */
+/*
+ * The following definitions set up the proper options for Macintosh
+ * compilers. We use this method because there is no autoconf equivalent.
+ */
+
+#ifdef MAC_TCL
+# ifndef HAS_STDARG
+# define HAS_STDARG 1
+# endif
+# ifndef USE_TCLALLOC
+# define USE_TCLALLOC 1
+# endif
+# ifndef NO_STRERROR
+# define NO_STRERROR 1
+# endif
+#endif
+
+/*
+ * A special definition used to allow this header file to be included
+ * in resource files so that they can get obtain version information from
+ * this file. Resource compilers don't like all the C stuff, like typedefs
+ * and procedure declarations, that occur below.
+ */
+
+#ifndef RESOURCE_INCLUDED
+
#ifndef BUFSIZ
#include <stdio.h>
#endif
-#define TCL_VERSION "7.5"
-#define TCL_MAJOR_VERSION 7
-#define TCL_MINOR_VERSION 5
-
/*
* Definitions that allow Tcl functions with variable numbers of
* arguments to be used with either varargs.h or stdarg.h. TCL_VARARGS
@@ -142,55 +198,69 @@ typedef long LONG;
#endif
/*
- * Data structures defined opaquely in this module. The definitions
- * below just provide dummy types. A few fields are made visible in
- * Tcl_Interp structures, namely those for returning string values.
- * Note: any change to the Tcl_Interp definition below must be mirrored
+ * Data structures defined opaquely in this module. The definitions below
+ * just provide dummy types. A few fields are made visible in Tcl_Interp
+ * structures, namely those used for returning a string result from
+ * commands. Direct access to the result field is discouraged in Tcl 8.0.
+ * The interpreter result is either an object or a string, and the two
+ * values are kept consistent unless some C code sets interp->result
+ * directly. Programmers should use either the procedure Tcl_GetObjResult()
+ * or Tcl_GetStringResult() to read the interpreter's result. See the
+ * SetResult man page for details.
+ *
+ * Note: any change to the Tcl_Interp definition below must be mirrored
* in the "real" definition in tclInt.h.
+ *
+ * Note: Tcl_ObjCmdProc procedures do not directly set result and freeProc.
+ * Instead, they set a Tcl_Obj member in the "real" structure that can be
+ * accessed with Tcl_GetObjResult() and Tcl_SetObjResult().
*/
-typedef struct Tcl_Interp{
- char *result; /* Points to result string returned by last
- * command. */
+typedef struct Tcl_Interp {
+ char *result; /* If the last command returned a string
+ * result, this points to it. */
void (*freeProc) _ANSI_ARGS_((char *blockPtr));
- /* Zero means result is statically allocated.
- * TCL_DYNAMIC means result was allocated with
- * ckalloc and should be freed with ckfree.
- * Other values give address of procedure
- * to invoke to free the result. Must be
- * freed by Tcl_Eval before executing next
- * command. */
- int errorLine; /* When TCL_ERROR is returned, this gives
- * the line number within the command where
- * the error occurred (1 means first line). */
+ /* Zero means the string result is
+ * statically allocated. TCL_DYNAMIC means
+ * it was allocated with ckalloc and should
+ * be freed with ckfree. Other values give
+ * the address of procedure to invoke to
+ * free the result. Tcl_Eval must free it
+ * before executing next command. */
+ int errorLine; /* When TCL_ERROR is returned, this gives
+ * the line number within the command where
+ * the error occurred (1 if first line). */
} Tcl_Interp;
typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler;
+typedef struct Tcl_Channel_ *Tcl_Channel;
typedef struct Tcl_Command_ *Tcl_Command;
typedef struct Tcl_Event Tcl_Event;
-typedef struct Tcl_File_ *Tcl_File;
-typedef struct Tcl_Channel_ *Tcl_Channel;
+typedef struct Tcl_Pid_ *Tcl_Pid;
typedef struct Tcl_RegExp_ *Tcl_RegExp;
typedef struct Tcl_TimerToken_ *Tcl_TimerToken;
typedef struct Tcl_Trace_ *Tcl_Trace;
+typedef struct Tcl_Var_ *Tcl_Var;
/*
- * When a TCL command returns, the string pointer interp->result points to
- * a string containing return information from the command. In addition,
- * the command procedure returns an integer value, which is one of the
- * following:
+ * When a TCL command returns, the interpreter contains a result from the
+ * command. Programmers are strongly encouraged to use one of the
+ * procedures Tcl_GetObjResult() or Tcl_GetStringResult() to read the
+ * interpreter's result. See the SetResult man page for details. Besides
+ * this result, the command procedure returns an integer code, which is
+ * one of the following:
*
- * TCL_OK Command completed normally; interp->result contains
- * the command's result.
+ * TCL_OK Command completed normally; the interpreter's
+ * result contains the command's result.
* TCL_ERROR The command couldn't be completed successfully;
- * interp->result describes what went wrong.
+ * the interpreter's result describes what went wrong.
* TCL_RETURN The command requests that the current procedure
- * return; interp->result contains the procedure's
- * return value.
+ * return; the interpreter's result contains the
+ * procedure's return value.
* TCL_BREAK The command requests that the innermost loop
- * be exited; interp->result is meaningless.
+ * be exited; the interpreter's result is meaningless.
* TCL_CONTINUE Go on to the next iteration of the current loop;
- * interp->result is meaningless.
+ * the interpreter's result is meaningless.
*/
#define TCL_OK 0
@@ -214,6 +284,14 @@ typedef struct Tcl_Value {
} Tcl_Value;
/*
+ * Forward declaration of Tcl_Obj to prevent an error when the forward
+ * reference to Tcl_Obj is encountered in the procedure types declared
+ * below.
+ */
+
+struct Tcl_Obj;
+
+/*
* Procedure types defined by Tcl:
*/
@@ -228,6 +306,8 @@ typedef int (Tcl_CmdProc) _ANSI_ARGS_((ClientData clientData,
typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc,
ClientData cmdClientData, int argc, char *argv[]));
+typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr,
+ struct Tcl_Obj *dupPtr));
typedef int (Tcl_EventProc) _ANSI_ARGS_((Tcl_Event *evPtr, int flags));
typedef void (Tcl_EventCheckProc) _ANSI_ARGS_((ClientData clientData,
int flags));
@@ -238,31 +318,231 @@ typedef void (Tcl_EventSetupProc) _ANSI_ARGS_((ClientData clientData,
typedef void (Tcl_ExitProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_FileProc) _ANSI_ARGS_((ClientData clientData, int mask));
typedef void (Tcl_FileFreeProc) _ANSI_ARGS_((ClientData clientData));
+typedef void (Tcl_FreeInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
typedef void (Tcl_FreeProc) _ANSI_ARGS_((char *blockPtr));
typedef void (Tcl_IdleProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_InterpDeleteProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp));
typedef int (Tcl_MathProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr));
+typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData));
+typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST objv[]));
typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData,
Tcl_Channel chan, char *address, int port));
typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData));
+typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ struct Tcl_Obj *objPtr));
+typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, char *part1, char *part2, int flags));
/*
- * The structure returned by Tcl_GetCmdInfo and passed into
- * Tcl_SetCmdInfo:
+ * The following structure represents a type of object, which is a
+ * particular internal representation for an object plus a set of
+ * procedures that provide standard operations on objects of that type.
+ */
+
+typedef struct Tcl_ObjType {
+ char *name; /* Name of the type, e.g. "int". */
+ Tcl_FreeInternalRepProc *freeIntRepProc;
+ /* Called to free any storage for the type's
+ * internal rep. NULL if the internal rep
+ * does not need freeing. */
+ Tcl_DupInternalRepProc *dupIntRepProc;
+ /* Called to create a new object as a copy
+ * of an existing object. */
+ Tcl_UpdateStringProc *updateStringProc;
+ /* Called to update the string rep from the
+ * type's internal representation. */
+ Tcl_SetFromAnyProc *setFromAnyProc;
+ /* Called to convert the object's internal
+ * rep to this type. Frees the internal rep
+ * of the old type. Returns TCL_ERROR on
+ * failure. */
+} Tcl_ObjType;
+
+/*
+ * One of the following structures exists for each object in the Tcl
+ * system. An object stores a value as either a string, some internal
+ * representation, or both.
*/
+typedef struct Tcl_Obj {
+ int refCount; /* When 0 the object will be freed. */
+ char *bytes; /* This points to the first byte of the
+ * object's string representation. The array
+ * must be followed by a null byte (i.e., at
+ * offset length) but may also contain
+ * embedded null characters. The array's
+ * storage is allocated by ckalloc. NULL
+ * means the string rep is invalid and must
+ * be regenerated from the internal rep.
+ * Clients should use Tcl_GetStringFromObj
+ * to get a pointer to the byte array as a
+ * readonly value. */
+ int length; /* The number of bytes at *bytes, not
+ * including the terminating null. */
+ Tcl_ObjType *typePtr; /* Denotes the object's type. Always
+ * corresponds to the type of the object's
+ * internal rep. NULL indicates the object
+ * has no internal rep (has no type). */
+ union { /* The internal representation: */
+ long longValue; /* - an long integer value */
+ double doubleValue; /* - a double-precision floating value */
+ VOID *otherValuePtr; /* - another, type-specific value */
+ struct { /* - internal rep as two pointers */
+ VOID *ptr1;
+ VOID *ptr2;
+ } twoPtrValue;
+ } internalRep;
+} Tcl_Obj;
+
+/*
+ * Macros to increment and decrement a Tcl_Obj's reference count, and to
+ * test whether an object is shared (i.e. has reference count > 1).
+ * Note: clients should use Tcl_DecrRefCount() when they are finished using
+ * an object, and should never call TclFreeObj() directly. TclFreeObj() is
+ * only defined and made public in tcl.h to support Tcl_DecrRefCount's macro
+ * definition. Note also that Tcl_DecrRefCount() refers to the parameter
+ * "obj" twice. This means that you should avoid calling it with an
+ * expression that is expensive to compute or has side effects.
+ */
+
+#define Tcl_IncrRefCount(objPtr) \
+ ++(objPtr)->refCount
+#define Tcl_DecrRefCount(objPtr) \
+ if (--(objPtr)->refCount <= 0) TclFreeObj(objPtr)
+#define Tcl_IsShared(objPtr) \
+ ((objPtr)->refCount > 1)
+
+/*
+ * Macros and definitions that help to debug the use of Tcl objects.
+ * When TCL_MEM_DEBUG is defined, the Tcl_New* declarations are
+ * overridden to call debugging versions of the object creation procedures.
+ */
+
+EXTERN Tcl_Obj * Tcl_NewBooleanObj _ANSI_ARGS_((int boolValue));
+EXTERN Tcl_Obj * Tcl_NewDoubleObj _ANSI_ARGS_((double doubleValue));
+EXTERN Tcl_Obj * Tcl_NewIntObj _ANSI_ARGS_((int intValue));
+EXTERN Tcl_Obj * Tcl_NewListObj _ANSI_ARGS_((int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN Tcl_Obj * Tcl_NewLongObj _ANSI_ARGS_((long longValue));
+EXTERN Tcl_Obj * Tcl_NewObj _ANSI_ARGS_((void));
+EXTERN Tcl_Obj * Tcl_NewStringObj _ANSI_ARGS_((char *bytes,
+ int length));
+
+#ifdef TCL_MEM_DEBUG
+# define Tcl_NewBooleanObj(val) \
+ Tcl_DbNewBooleanObj(val, __FILE__, __LINE__)
+# define Tcl_NewDoubleObj(val) \
+ Tcl_DbNewDoubleObj(val, __FILE__, __LINE__)
+# define Tcl_NewIntObj(val) \
+ Tcl_DbNewLongObj(val, __FILE__, __LINE__)
+# define Tcl_NewListObj(objc, objv) \
+ Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__)
+# define Tcl_NewLongObj(val) \
+ Tcl_DbNewLongObj(val, __FILE__, __LINE__)
+# define Tcl_NewObj() \
+ Tcl_DbNewObj(__FILE__, __LINE__)
+# define Tcl_NewStringObj(bytes, len) \
+ Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__)
+#endif /* TCL_MEM_DEBUG */
+
+/*
+ * The following definitions support Tcl's namespace facility.
+ * Note: the first five fields must match exactly the fields in a
+ * Namespace structure (see tcl.h).
+ */
+
+typedef struct Tcl_Namespace {
+ char *name; /* The namespace's name within its parent
+ * namespace. This contains no ::'s. The
+ * name of the global namespace is ""
+ * although "::" is an synonym. */
+ char *fullName; /* The namespace's fully qualified name.
+ * This starts with ::. */
+ ClientData clientData; /* Arbitrary value associated with this
+ * namespace. */
+ Tcl_NamespaceDeleteProc* deleteProc;
+ /* Procedure invoked when deleting the
+ * namespace to, e.g., free clientData. */
+ struct Tcl_Namespace* parentPtr;
+ /* Points to the namespace that contains
+ * this one. NULL if this is the global
+ * namespace. */
+} Tcl_Namespace;
+
+/*
+ * The following structure represents a call frame, or activation record.
+ * A call frame defines a naming context for a procedure call: its local
+ * scope (for local variables) and its namespace scope (used for non-local
+ * variables; often the global :: namespace). A call frame can also define
+ * the naming context for a namespace eval or namespace inscope command:
+ * the namespace in which the command's code should execute. The
+ * Tcl_CallFrame structures exist only while procedures or namespace
+ * eval/inscope's are being executed, and provide a Tcl call stack.
+ *
+ * A call frame is initialized and pushed using Tcl_PushCallFrame and
+ * popped using Tcl_PopCallFrame. Storage for a Tcl_CallFrame must be
+ * provided by the Tcl_PushCallFrame caller, and callers typically allocate
+ * them on the C call stack for efficiency. For this reason, Tcl_CallFrame
+ * is defined as a structure and not as an opaque token. However, most
+ * Tcl_CallFrame fields are hidden since applications should not access
+ * them directly; others are declared as "dummyX".
+ *
+ * WARNING!! The structure definition must be kept consistent with the
+ * CallFrame structure in tclInt.h. If you change one, change the other.
+ */
+
+typedef struct Tcl_CallFrame {
+ Tcl_Namespace *nsPtr;
+ int dummy1;
+ int dummy2;
+ char *dummy3;
+ char *dummy4;
+ char *dummy5;
+ int dummy6;
+ char *dummy7;
+ char *dummy8;
+ int dummy9;
+ char* dummy10;
+} Tcl_CallFrame;
+
+/*
+ * Information about commands that is returned by Tcl_GetCmdInfo and passed
+ * to Tcl_SetCmdInfo. objProc is an objc/objv object-based command procedure
+ * while proc is a traditional Tcl argc/argv string-based procedure.
+ * Tcl_CreateObjCommand and Tcl_CreateCommand ensure that both objProc and
+ * proc are non-NULL and can be called to execute the command. However,
+ * it may be faster to call one instead of the other. The member
+ * isNativeObjectProc is set to 1 if an object-based procedure was
+ * registered by Tcl_CreateObjCommand, and to 0 if a string-based procedure
+ * was registered by Tcl_CreateCommand. The other procedure is typically set
+ * to a compatibility wrapper that does string-to-object or object-to-string
+ * argument conversions then calls the other procedure.
+ */
+
typedef struct Tcl_CmdInfo {
- Tcl_CmdProc *proc; /* Procedure to implement command. */
- ClientData clientData; /* ClientData passed to proc. */
- Tcl_CmdDeleteProc *deleteProc; /* Procedure to call when command
- * is deleted. */
- ClientData deleteData; /* Value to pass to deleteProc (usually
- * the same as clientData). */
+ int isNativeObjectProc; /* 1 if objProc was registered by a call to
+ * Tcl_CreateObjCommand; 0 otherwise.
+ * Tcl_SetCmdInfo does not modify this
+ * field. */
+ Tcl_ObjCmdProc *objProc; /* Command's object-based procedure. */
+ ClientData objClientData; /* ClientData for object proc. */
+ Tcl_CmdProc *proc; /* Command's string-based procedure. */
+ ClientData clientData; /* ClientData for string proc. */
+ Tcl_CmdDeleteProc *deleteProc;
+ /* Procedure to call when command is
+ * deleted. */
+ ClientData deleteData; /* Value to pass to deleteProc (usually
+ * the same as clientData). */
+ Tcl_Namespace *namespacePtr; /* Points to the namespace that contains
+ * this command. Note that Tcl_SetCmdInfo
+ * will not change a command's namespace;
+ * use Tcl_RenameCommand to do that. */
+
} Tcl_CmdInfo;
/*
@@ -274,7 +554,7 @@ typedef struct Tcl_CmdInfo {
#define TCL_DSTRING_STATIC_SIZE 200
typedef struct Tcl_DString {
char *string; /* Points to beginning of string: either
- * staticSpace below or a malloc'ed array. */
+ * staticSpace below or a malloced array. */
int length; /* Number of non-NULL characters in the
* string. */
int spaceAvl; /* Total number of bytes available for the
@@ -293,7 +573,7 @@ typedef struct Tcl_DString {
* be specified in the "tcl_precision" variable, and the number of
* characters of buffer space required by Tcl_PrintDouble.
*/
-
+
#define TCL_MAX_PREC 17
#define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10)
@@ -306,6 +586,13 @@ typedef struct Tcl_DString {
#define TCL_DONT_USE_BRACES 1
/*
+ * Flag that may be passed to Tcl_GetIndexFromObj to force it to disallow
+ * abbreviated strings.
+ */
+
+#define TCL_EXACT 1
+
+/*
* Flag values passed to Tcl_RecordAndEval.
* WARNING: these bit choices must not conflict with the bit choices
* for evalFlag bits in tclInt.h!!
@@ -327,15 +614,17 @@ typedef struct Tcl_DString {
* Flag values passed to variable-related procedures.
*/
-#define TCL_GLOBAL_ONLY 1
-#define TCL_APPEND_VALUE 2
-#define TCL_LIST_ELEMENT 4
-#define TCL_TRACE_READS 0x10
-#define TCL_TRACE_WRITES 0x20
-#define TCL_TRACE_UNSETS 0x40
-#define TCL_TRACE_DESTROYED 0x80
-#define TCL_INTERP_DESTROYED 0x100
-#define TCL_LEAVE_ERR_MSG 0x200
+#define TCL_GLOBAL_ONLY 1
+#define TCL_NAMESPACE_ONLY 2
+#define TCL_APPEND_VALUE 4
+#define TCL_LIST_ELEMENT 8
+#define TCL_TRACE_READS 0x10
+#define TCL_TRACE_WRITES 0x20
+#define TCL_TRACE_UNSETS 0x40
+#define TCL_TRACE_DESTROYED 0x80
+#define TCL_INTERP_DESTROYED 0x100
+#define TCL_LEAVE_ERR_MSG 0x200
+#define TCL_PARSE_PART1 0x400
/*
* Types for linked variables:
@@ -388,21 +677,6 @@ EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file,
#endif /* TCL_MEM_DEBUG */
/*
- * Macro to free result of interpreter.
- */
-
-#define Tcl_FreeResult(interp) \
- if ((interp)->freeProc != 0) { \
- if (((interp)->freeProc == TCL_DYNAMIC) \
- || ((interp)->freeProc == (Tcl_FreeProc *) free)) { \
- ckfree((interp)->result); \
- } else { \
- (*(interp)->freeProc)((interp)->result); \
- } \
- (interp)->freeProc = 0; \
- }
-
-/*
* Forward declaration of Tcl_HashTable. Needed by some C++ compilers
* to prevent errors when the forward reference to Tcl_HashTable is
* encountered in the Tcl_HashEntry structure.
@@ -472,9 +746,9 @@ typedef struct Tcl_HashTable {
* is the size of the key.
*/
Tcl_HashEntry *(*findProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr,
- char *key));
+ CONST char *key));
Tcl_HashEntry *(*createProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr,
- char *key, int *newPtr));
+ CONST char *key, int *newPtr));
} Tcl_HashTable;
/*
@@ -545,7 +819,7 @@ struct Tcl_Event {
};
/*
- * Positions to pass to Tk_QueueEvent:
+ * Positions to pass to Tcl_QueueEvent:
*/
typedef enum {
@@ -553,6 +827,14 @@ typedef enum {
} Tcl_QueuePosition;
/*
+ * Values to pass to Tcl_SetServiceMode to specify the behavior of notifier
+ * event routines.
+ */
+
+#define TCL_SERVICE_NONE 0
+#define TCL_SERVICE_ALL 1
+
+/*
* The following structure keeps is used to hold a time value, either as
* an absolute time (the number of seconds from the epoch) or as an
* elapsed time. On Unix systems the epoch is Midnight Jan 1, 1970 GMT.
@@ -588,25 +870,27 @@ typedef struct Tcl_Time {
* Typedefs for the various operations in a channel type:
*/
-typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_((ClientData instanceData,
- Tcl_File inFile, Tcl_File outFile, int mode));
+typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_((
+ ClientData instanceData, int mode));
typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp, Tcl_File inFile, Tcl_File outFile));
+ Tcl_Interp *interp));
typedef int (Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData,
- Tcl_File inFile, char *buf, int toRead,
- int *errorCodePtr));
+ char *buf, int toRead, int *errorCodePtr));
typedef int (Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData,
- Tcl_File outFile, char *buf, int toWrite,
- int *errorCodePtr));
+ char *buf, int toWrite, int *errorCodePtr));
typedef int (Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData,
- Tcl_File inFile, Tcl_File outFile, long offset, int mode,
- int *errorCodePtr));
+ long offset, int mode, int *errorCodePtr));
typedef int (Tcl_DriverSetOptionProc) _ANSI_ARGS_((
ClientData instanceData, Tcl_Interp *interp,
- char *optionName, char *value));
+ char *optionName, char *value));
typedef int (Tcl_DriverGetOptionProc) _ANSI_ARGS_((
- ClientData instanceData, char *optionName,
- Tcl_DString *dsPtr));
+ ClientData instanceData, Tcl_Interp *interp,
+ char *optionName, Tcl_DString *dsPtr));
+typedef void (Tcl_DriverWatchProc) _ANSI_ARGS_((
+ ClientData instanceData, int mask));
+typedef int (Tcl_DriverGetHandleProc) _ANSI_ARGS_((
+ ClientData instanceData, int direction,
+ ClientData *handlePtr));
/*
* Enum for different end of line translation and recognition modes.
@@ -646,6 +930,11 @@ typedef struct Tcl_ChannelType {
/* Set an option on a channel. */
Tcl_DriverGetOptionProc *getOptionProc;
/* Get an option from a channel. */
+ Tcl_DriverWatchProc *watchProc; /* Set up the notifier to watch
+ * for events on this channel. */
+ Tcl_DriverGetHandleProc *getHandleProc;
+ /* Get an OS handle from the channel
+ * or NULL if not supported. */
} Tcl_ChannelType;
/*
@@ -659,18 +948,6 @@ typedef struct Tcl_ChannelType {
* mode. */
/*
- * Types for file handles:
- */
-
-#define TCL_UNIX_FD 1
-#define TCL_MAC_FILE 2
-#define TCL_MAC_SOCKET 3
-#define TCL_WIN_PIPE 4
-#define TCL_WIN_FILE 5
-#define TCL_WIN_SOCKET 6
-#define TCL_WIN_CONSOLE 7
-
-/*
* Enum for different types of file paths.
*/
@@ -681,27 +958,24 @@ typedef enum Tcl_PathType {
} Tcl_PathType;
/*
- * The following interface is exported for backwards compatibility, but
- * is only implemented on Unix. Portable applications should use
- * Tcl_OpenCommandChannel, instead.
- */
-
-EXTERN int Tcl_CreatePipeline _ANSI_ARGS_((Tcl_Interp *interp,
- int argc, char **argv, int **pidArrayPtr,
- int *inPipePtr, int *outPipePtr,
- int *errFilePtr));
-
-/*
* Exported Tcl procedures:
*/
EXTERN void Tcl_AddErrorInfo _ANSI_ARGS_((Tcl_Interp *interp,
char *message));
+EXTERN void Tcl_AddObjErrorInfo _ANSI_ARGS_((Tcl_Interp *interp,
+ char *message, int length));
EXTERN void Tcl_AllowExceptions _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN int Tcl_AppendAllObjTypes _ANSI_ARGS_((
+ Tcl_Interp *interp, Tcl_Obj *objPtr));
EXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp *interp,
char *string));
EXTERN void Tcl_AppendResult _ANSI_ARGS_(
- TCL_VARARGS(Tcl_Interp *,interp));
+ TCL_VARARGS(Tcl_Interp *,interp));
+EXTERN void Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj *objPtr,
+ char *bytes, int length));
+EXTERN void Tcl_AppendStringsToObj _ANSI_ARGS_(
+ TCL_VARARGS(Tcl_Obj *,interp));
EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN Tcl_AsyncHandler Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc *proc,
ClientData clientData));
@@ -713,6 +987,8 @@ EXTERN int Tcl_AsyncReady _ANSI_ARGS_((void));
EXTERN void Tcl_BackgroundError _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN char Tcl_Backslash _ANSI_ARGS_((char *src,
int *readPtr));
+EXTERN int Tcl_BadChannelOption _ANSI_ARGS_((Tcl_Interp *interp,
+ char *optionName, char *optionList));
EXTERN void Tcl_CallWhenDeleted _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_InterpDeleteProc *proc,
ClientData clientData));
@@ -725,15 +1001,24 @@ EXTERN int Tcl_Close _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Channel chan));
EXTERN int Tcl_CommandComplete _ANSI_ARGS_((char *cmd));
EXTERN char * Tcl_Concat _ANSI_ARGS_((int argc, char **argv));
+EXTERN Tcl_Obj * Tcl_ConcatObj _ANSI_ARGS_((int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int Tcl_ConvertCountedElement _ANSI_ARGS_((char *src,
+ int length, char *dst, int flags));
EXTERN int Tcl_ConvertElement _ANSI_ARGS_((char *src,
char *dst, int flags));
+EXTERN int Tcl_ConvertToType _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr, Tcl_ObjType *typePtr));
EXTERN int Tcl_CreateAlias _ANSI_ARGS_((Tcl_Interp *slave,
char *slaveCmd, Tcl_Interp *target,
char *targetCmd, int argc, char **argv));
+EXTERN int Tcl_CreateAliasObj _ANSI_ARGS_((Tcl_Interp *slave,
+ char *slaveCmd, Tcl_Interp *target,
+ char *targetCmd, int objc,
+ Tcl_Obj *CONST objv[]));
EXTERN Tcl_Channel Tcl_CreateChannel _ANSI_ARGS_((
Tcl_ChannelType *typePtr, char *chanName,
- Tcl_File inFile, Tcl_File outFile,
- ClientData instanceData));
+ ClientData instanceData, int mask));
EXTERN void Tcl_CreateChannelHandler _ANSI_ARGS_((
Tcl_Channel chan, int mask,
Tcl_ChannelProc *proc, ClientData clientData));
@@ -745,20 +1030,23 @@ EXTERN Tcl_Command Tcl_CreateCommand _ANSI_ARGS_((Tcl_Interp *interp,
ClientData clientData,
Tcl_CmdDeleteProc *deleteProc));
EXTERN void Tcl_CreateEventSource _ANSI_ARGS_((
- Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc
- *checkProc, ClientData clientData));
+ Tcl_EventSetupProc *setupProc,
+ Tcl_EventCheckProc *checkProc,
+ ClientData clientData));
EXTERN void Tcl_CreateExitHandler _ANSI_ARGS_((Tcl_ExitProc *proc,
ClientData clientData));
EXTERN void Tcl_CreateFileHandler _ANSI_ARGS_((
- Tcl_File file, int mask, Tcl_FileProc *proc,
+ int fd, int mask, Tcl_FileProc *proc,
ClientData clientData));
EXTERN Tcl_Interp * Tcl_CreateInterp _ANSI_ARGS_((void));
EXTERN void Tcl_CreateMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
char *name, int numArgs, Tcl_ValueType *argTypes,
Tcl_MathProc *proc, ClientData clientData));
-EXTERN void Tcl_CreateModalTimeout _ANSI_ARGS_((int milliseconds,
- Tcl_TimerProc *proc, ClientData clientData));
-EXTERN Tcl_Interp *Tcl_CreateSlave _ANSI_ARGS_((Tcl_Interp *interp,
+EXTERN Tcl_Command Tcl_CreateObjCommand _ANSI_ARGS_((
+ Tcl_Interp *interp, char *cmdName,
+ Tcl_ObjCmdProc *proc, ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc));
+EXTERN Tcl_Interp * Tcl_CreateSlave _ANSI_ARGS_((Tcl_Interp *interp,
char *slaveName, int isSafe));
EXTERN Tcl_TimerToken Tcl_CreateTimerHandler _ANSI_ARGS_((int milliseconds,
Tcl_TimerProc *proc, ClientData clientData));
@@ -771,39 +1059,49 @@ EXTERN int Tcl_DbCkfree _ANSI_ARGS_((char *ptr,
char *file, int line));
EXTERN char * Tcl_DbCkrealloc _ANSI_ARGS_((char *ptr,
unsigned int size, char *file, int line));
+EXTERN Tcl_Obj * Tcl_DbNewBooleanObj _ANSI_ARGS_((int boolValue,
+ char *file, int line));
+EXTERN Tcl_Obj * Tcl_DbNewDoubleObj _ANSI_ARGS_((double doubleValue,
+ char *file, int line));
+EXTERN Tcl_Obj * Tcl_DbNewListObj _ANSI_ARGS_((int objc,
+ Tcl_Obj *CONST objv[], char *file, int line));
+EXTERN Tcl_Obj * Tcl_DbNewLongObj _ANSI_ARGS_((long longValue,
+ char *file, int line));
+EXTERN Tcl_Obj * Tcl_DbNewObj _ANSI_ARGS_((char *file, int line));
+EXTERN Tcl_Obj * Tcl_DbNewStringObj _ANSI_ARGS_((char *bytes,
+ int length, char *file, int line));
EXTERN void Tcl_DeleteAssocData _ANSI_ARGS_((Tcl_Interp *interp,
char *name));
EXTERN int Tcl_DeleteCommand _ANSI_ARGS_((Tcl_Interp *interp,
char *cmdName));
+EXTERN int Tcl_DeleteCommandFromToken _ANSI_ARGS_((
+ Tcl_Interp *interp, Tcl_Command command));
EXTERN void Tcl_DeleteChannelHandler _ANSI_ARGS_((
Tcl_Channel chan, Tcl_ChannelProc *proc,
ClientData clientData));
EXTERN void Tcl_DeleteCloseHandler _ANSI_ARGS_((
Tcl_Channel chan, Tcl_CloseProc *proc,
ClientData clientData));
+EXTERN void Tcl_DeleteEvents _ANSI_ARGS_((
+ Tcl_EventDeleteProc *proc,
+ ClientData clientData));
EXTERN void Tcl_DeleteEventSource _ANSI_ARGS_((
Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc,
ClientData clientData));
-EXTERN void Tcl_DeleteEvents _ANSI_ARGS_((
- Tcl_EventDeleteProc *proc,
- ClientData clientData));
EXTERN void Tcl_DeleteExitHandler _ANSI_ARGS_((Tcl_ExitProc *proc,
ClientData clientData));
-EXTERN void Tcl_DeleteFileHandler _ANSI_ARGS_((
- Tcl_File file));
+EXTERN void Tcl_DeleteFileHandler _ANSI_ARGS_((int fd));
EXTERN void Tcl_DeleteHashEntry _ANSI_ARGS_((
Tcl_HashEntry *entryPtr));
EXTERN void Tcl_DeleteHashTable _ANSI_ARGS_((
Tcl_HashTable *tablePtr));
EXTERN void Tcl_DeleteInterp _ANSI_ARGS_((Tcl_Interp *interp));
-EXTERN void Tcl_DeleteModalTimeout _ANSI_ARGS_((
- Tcl_TimerProc *proc, ClientData clientData));
EXTERN void Tcl_DeleteTimerHandler _ANSI_ARGS_((
Tcl_TimerToken token));
EXTERN void Tcl_DeleteTrace _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Trace trace));
-EXTERN void Tcl_DetachPids _ANSI_ARGS_((int numPids, int *pidPtr));
+EXTERN void Tcl_DetachPids _ANSI_ARGS_((int numPids, Tcl_Pid *pidPtr));
EXTERN void Tcl_DontCallWhenDeleted _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_InterpDeleteProc *proc,
ClientData clientData));
@@ -825,51 +1123,73 @@ EXTERN void Tcl_DStringSetLength _ANSI_ARGS_((Tcl_DString *dsPtr,
int length));
EXTERN void Tcl_DStringStartSublist _ANSI_ARGS_((
Tcl_DString *dsPtr));
+EXTERN Tcl_Obj * Tcl_DuplicateObj _ANSI_ARGS_((Tcl_Obj *objPtr));
EXTERN int Tcl_Eof _ANSI_ARGS_((Tcl_Channel chan));
EXTERN char * Tcl_ErrnoId _ANSI_ARGS_((void));
EXTERN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err));
-EXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp *interp, char *cmd));
+EXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string));
EXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp *interp,
char *fileName));
EXTERN void Tcl_EventuallyFree _ANSI_ARGS_((ClientData clientData,
Tcl_FreeProc *freeProc));
+EXTERN int Tcl_EvalObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
EXTERN void Tcl_Exit _ANSI_ARGS_((int status));
+EXTERN int Tcl_ExposeCommand _ANSI_ARGS_((Tcl_Interp *interp,
+ char *hiddenCmdName, char *cmdName));
EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp *interp,
char *string, int *ptr));
+EXTERN int Tcl_ExprBooleanObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr, int *ptr));
EXTERN int Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp *interp,
char *string, double *ptr));
+EXTERN int Tcl_ExprDoubleObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr, double *ptr));
EXTERN int Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp *interp,
char *string, long *ptr));
+EXTERN int Tcl_ExprLongObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr, long *ptr));
+EXTERN int Tcl_ExprObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr));
EXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp *interp,
char *string));
-EXTERN int Tcl_FileReady _ANSI_ARGS_((Tcl_File file,
- int mask));
+EXTERN void Tcl_Finalize _ANSI_ARGS_((void));
EXTERN void Tcl_FindExecutable _ANSI_ARGS_((char *argv0));
EXTERN Tcl_HashEntry * Tcl_FirstHashEntry _ANSI_ARGS_((
Tcl_HashTable *tablePtr,
Tcl_HashSearch *searchPtr));
EXTERN int Tcl_Flush _ANSI_ARGS_((Tcl_Channel chan));
-EXTERN void Tcl_FreeFile _ANSI_ARGS_((
- Tcl_File file));
+EXTERN void TclFreeObj _ANSI_ARGS_((Tcl_Obj *objPtr));
+EXTERN void Tcl_FreeResult _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN int Tcl_GetAlias _ANSI_ARGS_((Tcl_Interp *interp,
char *slaveCmd, Tcl_Interp **targetInterpPtr,
char **targetCmdPtr, int *argcPtr,
char ***argvPtr));
+EXTERN int Tcl_GetAliasObj _ANSI_ARGS_((Tcl_Interp *interp,
+ char *slaveCmd, Tcl_Interp **targetInterpPtr,
+ char **targetCmdPtr, int *objcPtr,
+ Tcl_Obj ***objv));
EXTERN ClientData Tcl_GetAssocData _ANSI_ARGS_((Tcl_Interp *interp,
char *name, Tcl_InterpDeleteProc **procPtr));
EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp *interp,
char *string, int *boolPtr));
+EXTERN int Tcl_GetBooleanFromObj _ANSI_ARGS_((
+ Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int *boolPtr));
EXTERN Tcl_Channel Tcl_GetChannel _ANSI_ARGS_((Tcl_Interp *interp,
char *chanName, int *modePtr));
EXTERN int Tcl_GetChannelBufferSize _ANSI_ARGS_((
Tcl_Channel chan));
-EXTERN Tcl_File Tcl_GetChannelFile _ANSI_ARGS_((Tcl_Channel chan,
- int direction));
+EXTERN int Tcl_GetChannelHandle _ANSI_ARGS_((Tcl_Channel chan,
+ int direction, ClientData *handlePtr));
EXTERN ClientData Tcl_GetChannelInstanceData _ANSI_ARGS_((
Tcl_Channel chan));
-EXTERN int Tcl_GetChannelOption _ANSI_ARGS_((Tcl_Channel chan,
- char *optionName, Tcl_DString *dsPtr));
+EXTERN int Tcl_GetChannelMode _ANSI_ARGS_((Tcl_Channel chan));
EXTERN char * Tcl_GetChannelName _ANSI_ARGS_((Tcl_Channel chan));
+EXTERN int Tcl_GetChannelOption _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Channel chan, char *optionName,
+ Tcl_DString *dsPtr));
EXTERN Tcl_ChannelType * Tcl_GetChannelType _ANSI_ARGS_((Tcl_Channel chan));
EXTERN int Tcl_GetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp,
char *cmdName, Tcl_CmdInfo *infoPtr));
@@ -878,35 +1198,54 @@ EXTERN char * Tcl_GetCommandName _ANSI_ARGS_((Tcl_Interp *interp,
EXTERN char * Tcl_GetCwd _ANSI_ARGS_((char *buf, int len));
EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp *interp,
char *string, double *doublePtr));
+EXTERN int Tcl_GetDoubleFromObj _ANSI_ARGS_((
+ Tcl_Interp *interp, Tcl_Obj *objPtr,
+ double *doublePtr));
EXTERN int Tcl_GetErrno _ANSI_ARGS_((void));
-EXTERN Tcl_File Tcl_GetFile _ANSI_ARGS_((ClientData fileData,
- int type));
-EXTERN ClientData Tcl_GetFileInfo _ANSI_ARGS_((Tcl_File file,
- int *typePtr));
+EXTERN int Tcl_GetErrorLine _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN char * Tcl_GetHostName _ANSI_ARGS_((void));
+EXTERN int Tcl_GetIndexFromObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr, char **tablePtr, char *msg,
+ int flags, int *indexPtr));
EXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp *interp,
char *string, int *intPtr));
EXTERN int Tcl_GetInterpPath _ANSI_ARGS_((Tcl_Interp *askInterp,
Tcl_Interp *slaveInterp));
-EXTERN Tcl_Interp *Tcl_GetMaster _ANSI_ARGS_((Tcl_Interp *interp));
-EXTERN ClientData Tcl_GetNotifierData _ANSI_ARGS_((Tcl_File file,
- Tcl_FileFreeProc **freeProcPtr));
+EXTERN int Tcl_GetIntFromObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr, int *intPtr));
+EXTERN int Tcl_GetLongFromObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr, long *longPtr));
+EXTERN Tcl_Interp * Tcl_GetMaster _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN Tcl_Obj * Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN Tcl_ObjType * Tcl_GetObjType _ANSI_ARGS_((char *typeName));
EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp *interp,
char *string, int write, int checkUsage,
ClientData *filePtr));
+EXTERN Tcl_Command Tcl_GetOriginalCommand _ANSI_ARGS_((
+ Tcl_Command command));
EXTERN Tcl_PathType Tcl_GetPathType _ANSI_ARGS_((char *path));
EXTERN int Tcl_Gets _ANSI_ARGS_((Tcl_Channel chan,
Tcl_DString *dsPtr));
-EXTERN Tcl_Interp *Tcl_GetSlave _ANSI_ARGS_((Tcl_Interp *interp,
+EXTERN int Tcl_GetsObj _ANSI_ARGS_((Tcl_Channel chan,
+ Tcl_Obj *objPtr));
+EXTERN int Tcl_GetServiceMode _ANSI_ARGS_((void));
+EXTERN Tcl_Interp * Tcl_GetSlave _ANSI_ARGS_((Tcl_Interp *interp,
char *slaveName));
EXTERN Tcl_Channel Tcl_GetStdChannel _ANSI_ARGS_((int type));
+EXTERN char * Tcl_GetStringFromObj _ANSI_ARGS_((Tcl_Obj *objPtr,
+ int *lengthPtr));
+EXTERN char * Tcl_GetStringResult _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN char * Tcl_GetVar _ANSI_ARGS_((Tcl_Interp *interp,
char *varName, int flags));
EXTERN char * Tcl_GetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
char *part1, char *part2, int flags));
EXTERN int Tcl_GlobalEval _ANSI_ARGS_((Tcl_Interp *interp,
char *command));
+EXTERN int Tcl_GlobalEvalObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
EXTERN char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable *tablePtr));
+EXTERN int Tcl_HideCommand _ANSI_ARGS_((Tcl_Interp *interp,
+ char *cmdName, char *hiddenCmdName));
EXTERN int Tcl_Init _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN void Tcl_InitHashTable _ANSI_ARGS_((Tcl_HashTable *tablePtr,
int keyType));
@@ -915,20 +1254,47 @@ EXTERN int Tcl_InputBlocked _ANSI_ARGS_((Tcl_Channel chan));
EXTERN int Tcl_InputBuffered _ANSI_ARGS_((Tcl_Channel chan));
EXTERN int Tcl_InterpDeleted _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN int Tcl_IsSafe _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN void Tcl_InvalidateStringRep _ANSI_ARGS_((
+ Tcl_Obj *objPtr));
EXTERN char * Tcl_JoinPath _ANSI_ARGS_((int argc, char **argv,
Tcl_DString *resultPtr));
EXTERN int Tcl_LinkVar _ANSI_ARGS_((Tcl_Interp *interp,
char *varName, char *addr, int type));
+EXTERN int Tcl_ListObjAppendList _ANSI_ARGS_((
+ Tcl_Interp *interp, Tcl_Obj *listPtr,
+ Tcl_Obj *elemListPtr));
+EXTERN int Tcl_ListObjAppendElement _ANSI_ARGS_((
+ Tcl_Interp *interp, Tcl_Obj *listPtr,
+ Tcl_Obj *objPtr));
+EXTERN int Tcl_ListObjGetElements _ANSI_ARGS_((
+ Tcl_Interp *interp, Tcl_Obj *listPtr,
+ int *objcPtr, Tcl_Obj ***objvPtr));
+EXTERN int Tcl_ListObjIndex _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *listPtr, int index,
+ Tcl_Obj **objPtrPtr));
+EXTERN int Tcl_ListObjLength _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *listPtr, int *intPtr));
+EXTERN int Tcl_ListObjReplace _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *listPtr, int first, int count,
+ int objc, Tcl_Obj *CONST objv[]));
EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv,
Tcl_AppInitProc *appInitProc));
-EXTERN Tcl_Channel Tcl_MakeFileChannel _ANSI_ARGS_((ClientData inFile,
- ClientData outFile, int mode));
+EXTERN Tcl_Channel Tcl_MakeFileChannel _ANSI_ARGS_((ClientData handle,
+ int mode));
EXTERN int Tcl_MakeSafe _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN Tcl_Channel Tcl_MakeTcpClientChannel _ANSI_ARGS_((
ClientData tcpSocket));
EXTERN char * Tcl_Merge _ANSI_ARGS_((int argc, char **argv));
EXTERN Tcl_HashEntry * Tcl_NextHashEntry _ANSI_ARGS_((
Tcl_HashSearch *searchPtr));
+EXTERN void Tcl_NotifyChannel _ANSI_ARGS_((Tcl_Channel channel,
+ int mask));
+EXTERN Tcl_Obj * Tcl_ObjGetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
+ int flags));
+EXTERN Tcl_Obj * Tcl_ObjSetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
+ Tcl_Obj *newValuePtr, int flags));
EXTERN Tcl_Channel Tcl_OpenCommandChannel _ANSI_ARGS_((
Tcl_Interp *interp, int argc, char **argv,
int flags));
@@ -970,16 +1336,25 @@ EXTERN void Tcl_RegExpRange _ANSI_ARGS_((Tcl_RegExp regexp,
int index, char **startPtr, char **endPtr));
EXTERN void Tcl_RegisterChannel _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Channel chan));
+EXTERN void Tcl_RegisterObjType _ANSI_ARGS_((
+ Tcl_ObjType *typePtr));
EXTERN void Tcl_Release _ANSI_ARGS_((ClientData clientData));
+EXTERN void Tcl_RestartIdleTimer _ANSI_ARGS_((void));
EXTERN void Tcl_ResetResult _ANSI_ARGS_((Tcl_Interp *interp));
#define Tcl_Return Tcl_SetResult
+EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_((char *string,
+ int length, int *flagPtr));
EXTERN int Tcl_ScanElement _ANSI_ARGS_((char *string,
int *flagPtr));
EXTERN int Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan,
int offset, int mode));
+EXTERN int Tcl_ServiceAll _ANSI_ARGS_((void));
+EXTERN int Tcl_ServiceEvent _ANSI_ARGS_((int flags));
EXTERN void Tcl_SetAssocData _ANSI_ARGS_((Tcl_Interp *interp,
char *name, Tcl_InterpDeleteProc *proc,
ClientData clientData));
+EXTERN void Tcl_SetBooleanObj _ANSI_ARGS_((Tcl_Obj *objPtr,
+ int boolValue));
EXTERN void Tcl_SetChannelBufferSize _ANSI_ARGS_((
Tcl_Channel chan, int sz));
EXTERN int Tcl_SetChannelOption _ANSI_ARGS_((
@@ -987,20 +1362,36 @@ EXTERN int Tcl_SetChannelOption _ANSI_ARGS_((
char *optionName, char *newValue));
EXTERN int Tcl_SetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp,
char *cmdName, Tcl_CmdInfo *infoPtr));
-EXTERN void Tcl_SetErrno _ANSI_ARGS_((int errno));
+EXTERN void Tcl_SetDoubleObj _ANSI_ARGS_((Tcl_Obj *objPtr,
+ double doubleValue));
+EXTERN void Tcl_SetErrno _ANSI_ARGS_((int err));
EXTERN void Tcl_SetErrorCode _ANSI_ARGS_(
- TCL_VARARGS(Tcl_Interp *,interp));
+ TCL_VARARGS(Tcl_Interp *,arg1));
+EXTERN void Tcl_SetIntObj _ANSI_ARGS_((Tcl_Obj *objPtr,
+ int intValue));
+EXTERN void Tcl_SetListObj _ANSI_ARGS_((Tcl_Obj *objPtr,
+ int objc, Tcl_Obj *CONST objv[]));
+EXTERN void Tcl_SetLongObj _ANSI_ARGS_((Tcl_Obj *objPtr,
+ long longValue));
EXTERN void Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time *timePtr));
-EXTERN void Tcl_SetNotifierData _ANSI_ARGS_((Tcl_File file,
- Tcl_FileFreeProc *freeProcPtr, ClientData data));
+EXTERN void Tcl_SetObjErrorCode _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *errorObjPtr));
+EXTERN void Tcl_SetObjLength _ANSI_ARGS_((Tcl_Obj *objPtr,
+ int length));
+EXTERN void Tcl_SetObjResult _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *resultObjPtr));
EXTERN void Tcl_SetPanicProc _ANSI_ARGS_((void (*proc)
_ANSI_ARGS_(TCL_VARARGS(char *, format))));
EXTERN int Tcl_SetRecursionLimit _ANSI_ARGS_((Tcl_Interp *interp,
int depth));
EXTERN void Tcl_SetResult _ANSI_ARGS_((Tcl_Interp *interp,
char *string, Tcl_FreeProc *freeProc));
+EXTERN int Tcl_SetServiceMode _ANSI_ARGS_((int mode));
EXTERN void Tcl_SetStdChannel _ANSI_ARGS_((Tcl_Channel channel,
int type));
+EXTERN void Tcl_SetStringObj _ANSI_ARGS_((Tcl_Obj *objPtr,
+ char *bytes, int length));
+EXTERN void Tcl_SetTimer _ANSI_ARGS_((Tcl_Time *timePtr));
EXTERN char * Tcl_SetVar _ANSI_ARGS_((Tcl_Interp *interp,
char *varName, char *newValue, int flags));
EXTERN char * Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
@@ -1009,6 +1400,7 @@ EXTERN char * Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
EXTERN char * Tcl_SignalId _ANSI_ARGS_((int sig));
EXTERN char * Tcl_SignalMsg _ANSI_ARGS_((int sig));
EXTERN void Tcl_Sleep _ANSI_ARGS_((int ms));
+EXTERN void Tcl_SourceRCFile _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN int Tcl_SplitList _ANSI_ARGS_((Tcl_Interp *interp,
char *list, int *argcPtr, char ***argvPtr));
EXTERN void Tcl_SplitPath _ANSI_ARGS_((char *path,
@@ -1028,6 +1420,8 @@ EXTERN int Tcl_TraceVar2 _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_VarTraceProc *proc, ClientData clientData));
EXTERN char * Tcl_TranslateFileName _ANSI_ARGS_((Tcl_Interp *interp,
char *name, Tcl_DString *bufferPtr));
+EXTERN int Tcl_Ungets _ANSI_ARGS_((Tcl_Channel chan, char *str,
+ int len, int atHead));
EXTERN void Tcl_UnlinkVar _ANSI_ARGS_((Tcl_Interp *interp,
char *varName));
EXTERN int Tcl_UnregisterChannel _ANSI_ARGS_((Tcl_Interp *interp,
@@ -1061,11 +1455,12 @@ EXTERN ClientData Tcl_VarTraceInfo2 _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_VarTraceProc *procPtr,
ClientData prevClientData));
EXTERN int Tcl_WaitForEvent _ANSI_ARGS_((Tcl_Time *timePtr));
-EXTERN int Tcl_WaitPid _ANSI_ARGS_((int pid, int *statPtr,
- int options));
-EXTERN void Tcl_WatchFile _ANSI_ARGS_((Tcl_File file,
- int mask));
+EXTERN Tcl_Pid Tcl_WaitPid _ANSI_ARGS_((Tcl_Pid pid, int *statPtr,
+ int options));
EXTERN int Tcl_Write _ANSI_ARGS_((Tcl_Channel chan,
- char *s, int slen));
+ char *s, int slen));
+EXTERN void Tcl_WrongNumArgs _ANSI_ARGS_((Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[], char *message));
+#endif /* RESOURCE_INCLUDED */
#endif /* _TCL */
diff --git a/contrib/tcl/generic/tclBasic.c b/contrib/tcl/generic/tclBasic.c
index 7f39f80c12e0..c043dd4389c0 100644
--- a/contrib/tcl/generic/tclBasic.c
+++ b/contrib/tcl/generic/tclBasic.c
@@ -6,153 +6,233 @@
* and deletion, and command parsing and execution.
*
* Copyright (c) 1987-1994 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclBasic.c 1.211 96/05/10 17:48:04
+ * SCCS: @(#) tclBasic.c 1.280 97/05/20 19:09:26
*/
#include "tclInt.h"
+#include "tclCompile.h"
#ifndef TCL_GENERIC_ONLY
# include "tclPort.h"
#endif
-#include "patchlevel.h"
-
-/*
- * This variable indicates to the close procedures of channel drivers that
- * we are in the middle of an interpreter deletion, and hence in "implicit"
- * close mode. In that mode, the close procedures should not close the
- * OS handle for standard IO channels. Since interpreter deletion may be
- * recursive, this variable is actually a counter of the levels of nesting.
- */
-
-int tclInInterpreterDeletion = 0;
/*
* Static procedures in this file:
*/
static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
+static void HiddenCmdsDeleteProc _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp));
/*
- * The following structure defines all of the commands in the Tcl core,
- * and the C procedures that execute them.
+ * The following structure defines the commands in the Tcl core.
*/
typedef struct {
- char *name; /* Name of command. */
- Tcl_CmdProc *proc; /* Procedure that executes command. */
+ char *name; /* Name of object-based command. */
+ Tcl_CmdProc *proc; /* String-based procedure for command. */
+ Tcl_ObjCmdProc *objProc; /* Object-based procedure for command. */
+ CompileProc *compileProc; /* Procedure called to compile command. */
+ int isSafe; /* If non-zero, command will be present
+ * in safe interpreter. Otherwise it will
+ * be hidden. */
} CmdInfo;
/*
- * Built-in commands, and the procedures associated with them:
+ * The built-in commands, and the procedures that implement them:
*/
static CmdInfo builtInCmds[] = {
/*
- * Commands in the generic core:
- */
-
- {"append", Tcl_AppendCmd},
- {"array", Tcl_ArrayCmd},
- {"break", Tcl_BreakCmd},
- {"case", Tcl_CaseCmd},
- {"catch", Tcl_CatchCmd},
- {"clock", Tcl_ClockCmd},
- {"concat", Tcl_ConcatCmd},
- {"continue", Tcl_ContinueCmd},
- {"error", Tcl_ErrorCmd},
- {"eval", Tcl_EvalCmd},
- {"exit", Tcl_ExitCmd},
- {"expr", Tcl_ExprCmd},
- {"fileevent", Tcl_FileEventCmd},
- {"for", Tcl_ForCmd},
- {"foreach", Tcl_ForeachCmd},
- {"format", Tcl_FormatCmd},
- {"global", Tcl_GlobalCmd},
- {"history", Tcl_HistoryCmd},
- {"if", Tcl_IfCmd},
- {"incr", Tcl_IncrCmd},
- {"info", Tcl_InfoCmd},
- {"interp", Tcl_InterpCmd},
- {"join", Tcl_JoinCmd},
- {"lappend", Tcl_LappendCmd},
- {"lindex", Tcl_LindexCmd},
- {"linsert", Tcl_LinsertCmd},
- {"list", Tcl_ListCmd},
- {"llength", Tcl_LlengthCmd},
- {"load", Tcl_LoadCmd},
- {"lrange", Tcl_LrangeCmd},
- {"lreplace", Tcl_LreplaceCmd},
- {"lsearch", Tcl_LsearchCmd},
- {"lsort", Tcl_LsortCmd},
- {"package", Tcl_PackageCmd},
- {"proc", Tcl_ProcCmd},
- {"regexp", Tcl_RegexpCmd},
- {"regsub", Tcl_RegsubCmd},
- {"rename", Tcl_RenameCmd},
- {"return", Tcl_ReturnCmd},
- {"scan", Tcl_ScanCmd},
- {"set", Tcl_SetCmd},
- {"split", Tcl_SplitCmd},
- {"string", Tcl_StringCmd},
- {"subst", Tcl_SubstCmd},
- {"switch", Tcl_SwitchCmd},
- {"trace", Tcl_TraceCmd},
- {"unset", Tcl_UnsetCmd},
- {"uplevel", Tcl_UplevelCmd},
- {"upvar", Tcl_UpvarCmd},
- {"while", Tcl_WhileCmd},
+ * Commands in the generic core. Note that at least one of the proc or
+ * objProc members should be non-NULL. This avoids infinitely recursive
+ * calls between TclInvokeObjectCommand and TclInvokeStringCommand if a
+ * command name is computed at runtime and results in the name of a
+ * compiled command.
+ */
+
+ {"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd,
+ (CompileProc *) NULL, 1},
+ {"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd,
+ (CompileProc *) NULL, 1},
+ {"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd,
+ (CompileProc *) NULL, 1},
+ {"break", Tcl_BreakCmd, (Tcl_ObjCmdProc *) NULL,
+ TclCompileBreakCmd, 1},
+ {"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd,
+ (CompileProc *) NULL, 1},
+ {"catch", (Tcl_CmdProc *) NULL, Tcl_CatchObjCmd,
+ TclCompileCatchCmd, 1},
+ {"clock", (Tcl_CmdProc *) NULL, Tcl_ClockObjCmd,
+ (CompileProc *) NULL, 1},
+ {"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd,
+ (CompileProc *) NULL, 1},
+ {"continue", Tcl_ContinueCmd, (Tcl_ObjCmdProc *) NULL,
+ TclCompileContinueCmd, 1},
+ {"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd,
+ (CompileProc *) NULL, 1},
+ {"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd,
+ (CompileProc *) NULL, 1},
+ {"exit", (Tcl_CmdProc *) NULL, Tcl_ExitObjCmd,
+ (CompileProc *) NULL, 0},
+ {"expr", (Tcl_CmdProc *) NULL, Tcl_ExprObjCmd,
+ TclCompileExprCmd, 1},
+ {"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd,
+ (CompileProc *) NULL, 1},
+ {"fileevent", Tcl_FileEventCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 1},
+ {"for", Tcl_ForCmd, (Tcl_ObjCmdProc *) NULL,
+ TclCompileForCmd, 1},
+ {"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd,
+ TclCompileForeachCmd, 1},
+ {"format", Tcl_FormatCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 1},
+ {"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd,
+ (CompileProc *) NULL, 1},
+ {"history", Tcl_HistoryCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 1},
+ {"if", Tcl_IfCmd, (Tcl_ObjCmdProc *) NULL,
+ TclCompileIfCmd, 1},
+ {"incr", Tcl_IncrCmd, (Tcl_ObjCmdProc *) NULL,
+ TclCompileIncrCmd, 1},
+ {"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd,
+ (CompileProc *) NULL, 1},
+ {"interp", (Tcl_CmdProc *) NULL, Tcl_InterpObjCmd,
+ (CompileProc *) NULL, 1},
+ {"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd,
+ (CompileProc *) NULL, 1},
+ {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd,
+ (CompileProc *) NULL, 1},
+ {"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd,
+ (CompileProc *) NULL, 1},
+ {"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd,
+ (CompileProc *) NULL, 1},
+ {"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd,
+ (CompileProc *) NULL, 1},
+ {"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd,
+ (CompileProc *) NULL, 1},
+ {"load", Tcl_LoadCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 0},
+ {"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd,
+ (CompileProc *) NULL, 1},
+ {"lreplace", (Tcl_CmdProc *) NULL, Tcl_LreplaceObjCmd,
+ (CompileProc *) NULL, 1},
+ {"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd,
+ (CompileProc *) NULL, 1},
+ {"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd,
+ (CompileProc *) NULL, 1},
+ {"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd,
+ (CompileProc *) NULL, 1},
+ {"package", Tcl_PackageCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 1},
+ {"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd,
+ (CompileProc *) NULL, 1},
+ {"regexp", Tcl_RegexpCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 1},
+ {"regsub", Tcl_RegsubCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 1},
+ {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd,
+ (CompileProc *) NULL, 1},
+ {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd,
+ (CompileProc *) NULL, 1},
+ {"scan", Tcl_ScanCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 1},
+ {"set", Tcl_SetCmd, (Tcl_ObjCmdProc *) NULL,
+ TclCompileSetCmd, 1},
+ {"split", Tcl_SplitCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 1},
+ {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd,
+ (CompileProc *) NULL, 1},
+ {"subst", Tcl_SubstCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 1},
+ {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd,
+ (CompileProc *) NULL, 1},
+ {"trace", Tcl_TraceCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 1},
+ {"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd,
+ (CompileProc *) NULL, 1},
+ {"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd,
+ (CompileProc *) NULL, 1},
+ {"upvar", (Tcl_CmdProc *) NULL, Tcl_UpvarObjCmd,
+ (CompileProc *) NULL, 1},
+ {"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd,
+ (CompileProc *) NULL, 1},
+ {"while", Tcl_WhileCmd, (Tcl_ObjCmdProc *) NULL,
+ TclCompileWhileCmd, 1},
/*
* Commands in the UNIX core:
*/
#ifndef TCL_GENERIC_ONLY
- {"after", Tcl_AfterCmd},
- {"cd", Tcl_CdCmd},
- {"close", Tcl_CloseCmd},
- {"eof", Tcl_EofCmd},
- {"fblocked", Tcl_FblockedCmd},
- {"fconfigure", Tcl_FconfigureCmd},
- {"file", Tcl_FileCmd},
- {"flush", Tcl_FlushCmd},
- {"gets", Tcl_GetsCmd},
- {"glob", Tcl_GlobCmd},
- {"open", Tcl_OpenCmd},
- {"pid", Tcl_PidCmd},
- {"puts", Tcl_PutsCmd},
- {"pwd", Tcl_PwdCmd},
- {"read", Tcl_ReadCmd},
- {"seek", Tcl_SeekCmd},
- {"socket", Tcl_SocketCmd},
- {"tell", Tcl_TellCmd},
- {"time", Tcl_TimeCmd},
- {"update", Tcl_UpdateCmd},
- {"vwait", Tcl_VwaitCmd},
- {"unsupported0", TclUnsupported0Cmd},
-
-#ifndef MAC_TCL
- {"exec", Tcl_ExecCmd},
- {"source", Tcl_SourceCmd},
-#endif
+ {"after", Tcl_AfterCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 1},
+ {"cd", Tcl_CdCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 0},
+ {"close", Tcl_CloseCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 1},
+ {"eof", Tcl_EofCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 1},
+ {"fblocked", Tcl_FblockedCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 1},
+ {"fconfigure", Tcl_FconfigureCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 0},
+ {"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd,
+ (CompileProc *) NULL, 0},
+ {"flush", (Tcl_CmdProc *) NULL, Tcl_FlushObjCmd,
+ (CompileProc *) NULL, 1},
+ {"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd,
+ (CompileProc *) NULL, 1},
+ {"glob", Tcl_GlobCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 0},
+ {"open", Tcl_OpenCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 0},
+ {"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd,
+ (CompileProc *) NULL, 1},
+ {"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd,
+ (CompileProc *) NULL, 1},
+ {"pwd", Tcl_PwdCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 0},
+ {"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd,
+ (CompileProc *) NULL, 1},
+ {"seek", Tcl_SeekCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 1},
+ {"socket", Tcl_SocketCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 0},
+ {"tell", Tcl_TellCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 1},
+ {"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd,
+ (CompileProc *) NULL, 1},
+ {"update", Tcl_UpdateCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 1},
+ {"vwait", Tcl_VwaitCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 0},
#ifdef MAC_TCL
- {"beep", Tcl_MacBeepCmd},
- {"cp", Tcl_CpCmd},
- {"echo", Tcl_EchoCmd},
- {"ls", Tcl_LsCmd},
- {"mkdir", Tcl_MkdirCmd},
- {"mv", Tcl_MvCmd},
- {"rm", Tcl_RmCmd},
- {"rmdir", Tcl_RmdirCmd},
- {"source", Tcl_MacSourceCmd},
+ {"beep", (Tcl_CmdProc *) NULL, Tcl_BeepObjCmd,
+ (CompileProc *) NULL, 0},
+ {"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 0},
+ {"ls", Tcl_LsCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 0},
+ {"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd,
+ (CompileProc *) NULL, 1},
+ {"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd,
+ (CompileProc *) NULL, 0},
+#else
+ {"exec", Tcl_ExecCmd, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 0},
+ {"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd,
+ (CompileProc *) NULL, 0},
#endif /* MAC_TCL */
#endif /* TCL_GENERIC_ONLY */
- {NULL, (Tcl_CmdProc *) NULL}
+ {NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL,
+ (CompileProc *) NULL, 0}
};
/*
@@ -180,16 +260,36 @@ Tcl_CreateInterp()
register Interp *iPtr;
register Command *cmdPtr;
register CmdInfo *cmdInfoPtr;
- Tcl_Channel chan;
+ union {
+ char c[sizeof(short)];
+ short s;
+ } order;
int i;
+ /*
+ * Panic if someone updated the CallFrame structure without
+ * also updating the Tcl_CallFrame structure (or vice versa).
+ */
+
+ if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) {
+ panic("Tcl_CallFrame and CallFrame are not the same size");
+ }
+
+ /*
+ * Initialize support for namespaces and create the global namespace
+ * (whose name is ""; an alias is "::"). This also initializes the
+ * Tcl object type table and other object management code.
+ */
+
+ TclInitNamespaces();
+
iPtr = (Interp *) ckalloc(sizeof(Interp));
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
+ iPtr->objResultPtr = Tcl_NewObj(); /* an empty object */
+ Tcl_IncrRefCount(iPtr->objResultPtr);
iPtr->errorLine = 0;
- Tcl_InitHashTable(&iPtr->commandTable, TCL_STRING_KEYS);
Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
- Tcl_InitHashTable(&iPtr->globalTable, TCL_STRING_KEYS);
iPtr->numLevels = 0;
iPtr->maxNestingDepth = 1000;
iPtr->framePtr = NULL;
@@ -216,37 +316,85 @@ Tcl_CreateInterp()
}
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
iPtr->packageUnknown = NULL;
- strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT);
- iPtr->pdPrec = DEFAULT_PD_PREC;
iPtr->cmdCount = 0;
- iPtr->noEval = 0;
+ iPtr->termOffset = 0;
+ iPtr->compileEpoch = 0;
+ iPtr->compiledProcPtr = NULL;
iPtr->evalFlags = 0;
iPtr->scriptFile = NULL;
iPtr->flags = 0;
iPtr->tracePtr = NULL;
iPtr->assocData = (Tcl_HashTable *) NULL;
+ iPtr->execEnvPtr = NULL; /* set after namespaces initialized */
+ iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */
+ Tcl_IncrRefCount(iPtr->emptyObjPtr);
iPtr->resultSpace[0] = 0;
+ iPtr->globalNsPtr = NULL; /* force creation of global ns below */
+ iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(
+ (Tcl_Interp *) iPtr, "", (ClientData) NULL,
+ (Tcl_NamespaceDeleteProc *) NULL);
+ if (iPtr->globalNsPtr == NULL) {
+ panic("Tcl_CreateInterp: can't create global namespace");
+ }
+
/*
- * Create the built-in commands. Do it here, rather than calling
- * Tcl_CreateCommand, because it's faster (there's no need to
- * check for a pre-existing command by the same name).
+ * Initialize support for code compilation. Do this after initializing
+ * namespaces since TclCreateExecEnv will try to reference a Tcl
+ * variable (it links to the Tcl "tcl_traceExec" variable).
*/
+
+ iPtr->execEnvPtr = TclCreateExecEnv((Tcl_Interp *) iPtr);
- for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
+ /*
+ * Create the core commands. Do it here, rather than calling
+ * Tcl_CreateCommand, because it's faster (there's no need to check for
+ * a pre-existing command by the same name). If a command has a
+ * Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to
+ * TclInvokeStringCommand. This is an object-based wrapper procedure
+ * that extracts strings, calls the string procedure, and creates an
+ * object for the result. Similarly, if a command has a Tcl_ObjCmdProc
+ * but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand.
+ */
+
+ for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL;
+ cmdInfoPtr++) {
int new;
Tcl_HashEntry *hPtr;
- hPtr = Tcl_CreateHashEntry(&iPtr->commandTable,
- cmdInfoPtr->name, &new);
+ if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL)
+ && (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL)
+ && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) {
+ panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n");
+ }
+
+ hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
+ cmdInfoPtr->name, &new);
if (new) {
cmdPtr = (Command *) ckalloc(sizeof(Command));
cmdPtr->hPtr = hPtr;
- cmdPtr->proc = cmdInfoPtr->proc;
- cmdPtr->clientData = (ClientData) NULL;
+ cmdPtr->nsPtr = iPtr->globalNsPtr;
+ cmdPtr->refCount = 1;
+ cmdPtr->cmdEpoch = 0;
+ cmdPtr->compileProc = cmdInfoPtr->compileProc;
+ if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) {
+ cmdPtr->proc = TclInvokeObjectCommand;
+ cmdPtr->clientData = (ClientData) cmdPtr;
+ } else {
+ cmdPtr->proc = cmdInfoPtr->proc;
+ cmdPtr->clientData = (ClientData) NULL;
+ }
+ if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
+ cmdPtr->objProc = TclInvokeStringCommand;
+ cmdPtr->objClientData = (ClientData) cmdPtr;
+ } else {
+ cmdPtr->objProc = cmdInfoPtr->objProc;
+ cmdPtr->objClientData = (ClientData) NULL;
+ }
cmdPtr->deleteProc = NULL;
cmdPtr->deleteData = (ClientData) NULL;
cmdPtr->deleted = 0;
+ cmdPtr->importRefPtr = NULL;
Tcl_SetHashValue(hPtr, cmdPtr);
}
}
@@ -270,37 +418,60 @@ Tcl_CreateInterp()
TCL_GLOBAL_ONLY);
Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION,
TCL_GLOBAL_ONLY);
- Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- TclPrecTraceProc, (ClientData) NULL);
/*
- * Register Tcl's version number.
+ * Compute the byte order of this machine.
*/
- Tcl_PkgProvide((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION);
+ order.s = 1;
+ Tcl_SetVar2((Tcl_Interp *) iPtr, "tcl_platform", "byteOrder",
+ (order.c[0] == 1) ? "litteEndian" : "bigEndian",
+ TCL_GLOBAL_ONLY);
/*
- * Add the standard channels.
+ * Register Tcl's version number.
*/
- chan = Tcl_GetStdChannel(TCL_STDIN);
- if (chan != (Tcl_Channel) NULL) {
- Tcl_RegisterChannel((Tcl_Interp *) iPtr, chan);
- }
- chan = Tcl_GetStdChannel(TCL_STDOUT);
- if (chan != (Tcl_Channel) NULL) {
- Tcl_RegisterChannel((Tcl_Interp *) iPtr, chan);
- }
- chan = Tcl_GetStdChannel(TCL_STDERR);
- if (chan != (Tcl_Channel) NULL) {
- Tcl_RegisterChannel((Tcl_Interp *) iPtr, chan);
- }
+ Tcl_PkgProvide((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION);
return (Tcl_Interp *) iPtr;
}
/*
+ *----------------------------------------------------------------------
+ *
+ * TclHideUnsafeCommands --
+ *
+ * Hides base commands that are not marked as safe from this
+ * interpreter.
+ *
+ * Results:
+ * TCL_OK if it succeeds, TCL_ERROR else.
+ *
+ * Side effects:
+ * Hides functionality in an interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclHideUnsafeCommands(interp)
+ Tcl_Interp *interp; /* Hide commands in this interpreter. */
+{
+ register CmdInfo *cmdInfoPtr;
+
+ if (interp == (Tcl_Interp *) NULL) {
+ return TCL_ERROR;
+ }
+ for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
+ if (!cmdInfoPtr->isSafe) {
+ Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
+ }
+ }
+ return TCL_OK;
+}
+
+/*
*--------------------------------------------------------------
*
* Tcl_CallWhenDeleted --
@@ -558,9 +729,9 @@ DeleteInterpProc(interp)
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
- int i;
Tcl_HashTable *hTablePtr;
AssocData *dPtr;
+ int i;
/*
* Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
@@ -580,38 +751,27 @@ DeleteInterpProc(interp)
}
/*
- * Increment the interp deletion counter, so that close procedures
- * for channel drivers can notice that we are in "implicit" close mode.
+ * Dismantle everything in the global namespace except for the
+ * "errorInfo" and "errorCode" variables. These remain until the
+ * namespace is actually destroyed, in case any errors occur.
+ *
+ * Dismantle the namespace here, before we clear the assocData. If any
+ * background errors occur here, they will be deleted below.
*/
-
- tclInInterpreterDeletion++;
+ TclTeardownNamespace(iPtr->globalNsPtr);
+
/*
- * First delete all the commands. There's a special hack here
- * because "tkerror" is just a synonym for "bgerror" (they share
- * a Command structure). Just delete the hash table entry for
- * "tkerror" without invoking its callback or cleaning up its
- * Command structure.
+ * Tear down the math function table.
*/
- hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "tkerror");
- if (hPtr != NULL) {
- Tcl_DeleteHashEntry(hPtr);
- }
- for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
- hPtr != NULL;
- hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search)) {
- Tcl_DeleteCommand(interp,
- Tcl_GetHashKey(&iPtr->commandTable, hPtr));
- }
- Tcl_DeleteHashTable(&iPtr->commandTable);
for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
ckfree((char *) Tcl_GetHashValue(hPtr));
}
Tcl_DeleteHashTable(&iPtr->mathFuncTable);
-
+
/*
* Invoke deletion callbacks; note that a callback can create new
* callbacks, so we iterate.
@@ -635,10 +795,10 @@ DeleteInterpProc(interp)
}
/*
- * Delete all global variables:
+ * Finish deleting the global namespace.
*/
- TclDeleteVars(iPtr, &iPtr->globalTable);
+ Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);
/*
* Free up the result *after* deleting variables, since variable
@@ -648,7 +808,8 @@ DeleteInterpProc(interp)
Tcl_FreeResult(interp);
interp->result = NULL;
-
+ Tcl_DecrRefCount(iPtr->objResultPtr);
+ iPtr->objResultPtr = NULL;
if (iPtr->errorInfo != NULL) {
ckfree(iPtr->errorInfo);
iPtr->errorInfo = NULL;
@@ -658,8 +819,6 @@ DeleteInterpProc(interp)
iPtr->errorCode = NULL;
}
if (iPtr->events != NULL) {
- int i;
-
for (i = 0; i < iPtr->numEvents; i++) {
ckfree(iPtr->events[i].command);
}
@@ -692,15 +851,11 @@ DeleteInterpProc(interp)
ckfree((char *) iPtr->tracePtr);
iPtr->tracePtr = nextPtr;
}
-
- /*
- * Finally decrement the nested interpreter deletion counter.
- */
-
- tclInInterpreterDeletion--;
- if (tclInInterpreterDeletion < 0) {
- tclInInterpreterDeletion = 0;
+ if (iPtr->execEnvPtr != NULL) {
+ TclDeleteExecEnv(iPtr->execEnvPtr);
}
+ Tcl_DecrRefCount(iPtr->emptyObjPtr);
+ iPtr->emptyObjPtr = NULL;
ckfree((char *) iPtr);
}
@@ -784,41 +939,488 @@ Tcl_DeleteInterp(interp)
/*
*----------------------------------------------------------------------
*
+ * HiddenCmdsDeleteProc --
+ *
+ * Called on interpreter deletion to delete all the hidden
+ * commands in an interpreter.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees up memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+HiddenCmdsDeleteProc(clientData, interp)
+ ClientData clientData; /* The hidden commands hash table. */
+ Tcl_Interp *interp; /* The interpreter being deleted. */
+{
+ Tcl_HashTable *hiddenCmdTblPtr;
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch hSearch;
+ Command *cmdPtr;
+
+ hiddenCmdTblPtr = (Tcl_HashTable *) clientData;
+ hPtr = Tcl_FindHashEntry(hiddenCmdTblPtr, "tkerror");
+ if (hPtr != NULL) {
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ for (hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch);
+ hPtr != NULL;
+ hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch)) {
+
+ /*
+ * Cannot use Tcl_DeleteCommand because (a) the command is not
+ * in the command hash table, and (b) that table has already been
+ * deleted above. Hence we emulate what it does, below.
+ */
+
+ cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
+
+ /*
+ * The code here is tricky. We can't delete the hash table entry
+ * before invoking the deletion callback because there are cases
+ * where the deletion callback needs to invoke the command (e.g.
+ * object systems such as OTcl). However, this means that the
+ * callback could try to delete or rename the command. The deleted
+ * flag allows us to detect these cases and skip nested deletes.
+ */
+
+ if (cmdPtr->deleted) {
+
+ /*
+ * Another deletion is already in progress. Remove the hash
+ * table entry now, but don't invoke a callback or free the
+ * command structure.
+ */
+
+ Tcl_DeleteHashEntry(cmdPtr->hPtr);
+ cmdPtr->hPtr = NULL;
+ continue;
+ }
+ cmdPtr->deleted = 1;
+ if (cmdPtr->deleteProc != NULL) {
+ (*cmdPtr->deleteProc)(cmdPtr->deleteData);
+ }
+
+ /*
+ * Bump the command epoch counter. This will invalidate all cached
+ * references that refer to this command.
+ */
+
+ cmdPtr->cmdEpoch++;
+
+ /*
+ * Don't use hPtr to delete the hash entry here, because it's
+ * possible that the deletion callback renamed the command.
+ * Instead, use cmdPtr->hptr, and make sure that no-one else
+ * has already deleted the hash entry.
+ */
+
+ if (cmdPtr->hPtr != NULL) {
+ Tcl_DeleteHashEntry(cmdPtr->hPtr);
+ }
+ ckfree((char *) cmdPtr);
+ }
+ Tcl_DeleteHashTable(hiddenCmdTblPtr);
+ ckfree((char *) hiddenCmdTblPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_HideCommand --
+ *
+ * Makes a command hidden so that it cannot be invoked from within
+ * an interpreter, only from within an ancestor.
+ *
+ * Results:
+ * A standard Tcl result; also leaves a message in interp->result
+ * if an error occurs.
+ *
+ * Side effects:
+ * Moves a command from the command table to the hidden command
+ * table.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_HideCommand(interp, cmdName, hiddenCmdName)
+ Tcl_Interp *interp; /* Interpreter in which to hide command. */
+ char *cmdName; /* Name of hidden command. */
+ char *hiddenCmdName; /* Name of to-be-hidden command. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Command cmd;
+ Command *cmdPtr;
+ Tcl_HashTable *hTblPtr;
+ Tcl_HashEntry *hPtr, *tkErrorHPtr;
+ int isBgerror, new;
+
+ if (iPtr->flags & DELETED) {
+
+ /*
+ * The interpreter is being deleted. Do not create any new
+ * structures, because it is not safe to modify the interpreter.
+ */
+
+ return TCL_ERROR;
+ }
+
+ if (strstr(hiddenCmdName, "::") != NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "hidden command names can't have namespace qualifiers",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Find the command to hide. An error is returned if cmdName can't
+ * be found.
+ */
+
+ cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
+ /*flags*/ TCL_LEAVE_ERR_MSG);
+ if (cmd == (Tcl_Command) NULL) {
+ return TCL_ERROR;
+ }
+ cmdPtr = (Command *) cmd;
+
+ /*
+ * If this command is the "bgerror" command in the global namespace,
+ * make note of it now. We'll need to know this later so that we can
+ * handle its "tkerror" twin below.
+ */
+
+ isBgerror = 0;
+ if (cmdPtr->hPtr != NULL) {
+ char *tail = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
+ if ((*tail == 'b') && (strcmp(tail, "bgerror") == 0)
+ && (cmdPtr->nsPtr == iPtr->globalNsPtr)) {
+ isBgerror = 1;
+ }
+ }
+
+ /*
+ * Initialize the hidden command table if necessary.
+ */
+
+ hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds",
+ NULL);
+ if (hTblPtr == (Tcl_HashTable *) NULL) {
+ hTblPtr = (Tcl_HashTable *)
+ ckalloc((unsigned) sizeof(Tcl_HashTable));
+ Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS);
+ Tcl_SetAssocData(interp, "tclHiddenCmds", HiddenCmdsDeleteProc,
+ (ClientData) hTblPtr);
+ }
+
+ /*
+ * It is an error to move an exposed command to a hidden command with
+ * hiddenCmdName if a hidden command with the name hiddenCmdName already
+ * exists.
+ */
+
+ hPtr = Tcl_CreateHashEntry(hTblPtr, hiddenCmdName, &new);
+ if (!new) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "hidden command named \"", hiddenCmdName, "\" already exists",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Remove the hash entry for the command from the interpreter command
+ * table. This is like deleting the command, so bump its command epoch;
+ * this invalidates any cached references that point to the command.
+ */
+
+ if (cmdPtr->hPtr != NULL) {
+ Tcl_DeleteHashEntry(cmdPtr->hPtr);
+ cmdPtr->hPtr = (Tcl_HashEntry *) NULL;
+ cmdPtr->cmdEpoch++;
+ }
+
+ /*
+ * If we are creating a hidden command named "bgerror", share the
+ * command data structure with another command named "tkerror". This
+ * code should eventually be removed.
+ */
+
+ if (isBgerror) {
+ tkErrorHPtr = Tcl_CreateHashEntry(hTblPtr, "tkerror", &new);
+ if (!new) {
+ panic("Tcl_HideCommand: hiding bgerror while tkerror is already hidden!");
+ }
+ Tcl_SetHashValue(tkErrorHPtr, (ClientData) cmdPtr);
+ tkErrorHPtr = Tcl_FindHashEntry(&(iPtr->globalNsPtr->cmdTable),
+ "tkerror");
+ if (tkErrorHPtr != (Tcl_HashEntry *) NULL) {
+ Tcl_DeleteHashEntry(tkErrorHPtr);
+ }
+ }
+
+ /*
+ * Now link the hash table entry with the command structure. Keep the
+ * containing namespace the same. After all, the command really
+ * "belongs" to that namespace.
+ */
+
+ cmdPtr->hPtr = hPtr;
+ Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
+
+ /*
+ * If the command being hidden has a compile procedure, increment the
+ * interpreter's compileEpoch to invalidate its compiled code. This
+ * makes sure that we don't later try to execute old code compiled with
+ * command-specific (i.e., inline) bytecodes for the now-hidden
+ * command. This field is checked in Tcl_EvalObj and ObjInterpProc,
+ * and code whose compilation epoch doesn't match is recompiled.
+ */
+
+ if (cmdPtr->compileProc != NULL) {
+ iPtr->compileEpoch++;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ExposeCommand --
+ *
+ * Makes a previously hidden command callable from inside the
+ * interpreter instead of only by its ancestors.
+ *
+ * Results:
+ * A standard Tcl result. If an error occurs, a message is left
+ * in interp->result.
+ *
+ * Side effects:
+ * Moves commands from one hash table to another.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ExposeCommand(interp, hiddenCmdName, cmdName)
+ Tcl_Interp *interp; /* Interpreter in which to make command
+ * callable. */
+ char *hiddenCmdName; /* Name of hidden command. */
+ char *cmdName; /* Name of to-be-exposed command. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Command *cmdPtr;
+ Namespace *nsPtr, *dummy1, *dummy2;
+ Tcl_HashEntry *hPtr, *tkErrorHPtr;
+ Tcl_HashTable *hTblPtr;
+ char *tail;
+ int new, result;
+
+ if (iPtr->flags & DELETED) {
+ /*
+ * The interpreter is being deleted. Do not create any new
+ * structures, because it is not safe to modify the interpreter.
+ */
+
+ return TCL_ERROR;
+ }
+
+ /*
+ * Find the hash table for the hidden commands; error out if there
+ * is none.
+ */
+
+ hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds",
+ NULL);
+ if (hTblPtr == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "unknown hidden command \"", hiddenCmdName,
+ "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the command from the hidden command table:
+ */
+
+ hPtr = Tcl_FindHashEntry(hTblPtr, hiddenCmdName);
+ if (hPtr == (Tcl_HashEntry *) NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "unknown hidden command \"", hiddenCmdName,
+ "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
+
+ /*
+ * Normally, the command will go right back into its containing
+ * namespace. But if the exposed command name has "::" namespace
+ * qualifiers, it is being moved to another context.
+ */
+
+ if (strstr(cmdName, "::") != NULL) {
+ result = TclGetNamespaceForQualName(interp, cmdName,
+ iPtr->globalNsPtr,
+ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
+ &nsPtr, &dummy1, &dummy2, &tail);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if ((nsPtr == NULL) || (tail == NULL)) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "bad command name \"", cmdName, "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ } else {
+ nsPtr = cmdPtr->nsPtr;
+ tail = cmdName;
+ }
+
+ /*
+ * It is an error to overwrite an existing exposed command as a result
+ * of exposing a previously hidden command.
+ */
+
+ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
+ if (!new) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "exposed command \"", cmdName,
+ "\" already exists", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Remove the hash entry for the command from the interpreter hidden
+ * command table.
+ */
+
+ if (cmdPtr->hPtr != NULL) {
+ Tcl_DeleteHashEntry(cmdPtr->hPtr);
+ cmdPtr->hPtr = NULL;
+ }
+
+ /*
+ * If we are creating a command named "bgerror", share the command
+ * data structure with another command named "tkerror". This code
+ * should eventually be removed.
+ */
+
+ if ((*tail == 'b') && (strcmp(tail, "bgerror") == 0)
+ && (nsPtr == iPtr->globalNsPtr)) {
+ tkErrorHPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
+ "tkerror", &new);
+ if (!new) {
+ panic("Tcl_ExposeCommand: exposing bgerror while tkerror is already exposed!");
+ }
+ Tcl_SetHashValue(tkErrorHPtr, (ClientData) cmdPtr);
+ tkErrorHPtr = Tcl_FindHashEntry(hTblPtr, "tkerror");
+ if (tkErrorHPtr != NULL) {
+ Tcl_DeleteHashEntry(tkErrorHPtr);
+ }
+ }
+
+ /*
+ * Now link the hash table entry with the command structure.
+ * This is like creating a new command, so deal with any shadowing
+ * of commands in the global namespace.
+ */
+
+ cmdPtr->hPtr = hPtr;
+ cmdPtr->nsPtr = nsPtr;
+ Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
+ TclResetShadowedCmdRefs(interp, cmdPtr);
+
+ /*
+ * If the command being exposed has a compile procedure, increment
+ * interpreter's compileEpoch to invalidate its compiled code. This
+ * makes sure that we don't later try to execute old code compiled
+ * assuming the command is hidden. This field is checked in Tcl_EvalObj
+ * and ObjInterpProc, and code whose compilation epoch doesn't match is
+ * recompiled.
+ */
+
+ if (cmdPtr->compileProc != NULL) {
+ iPtr->compileEpoch++;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_CreateCommand --
*
* Define a new command in a command table.
*
* Results:
* The return value is a token for the command, which can
- * be used in future calls to Tcl_NameOfCommand.
+ * be used in future calls to Tcl_GetCommandName.
*
* Side effects:
- * If a command named cmdName already exists for interp, it is
- * deleted. In the future, when cmdName is seen as the name of
- * a command by Tcl_Eval, proc will be called. When the command
- * is deleted from the table, deleteProc will be called. See the
- * manual entry for details on the calling sequence.
+ * If a command named cmdName already exists for interp, it is deleted.
+ * In the future, when cmdName is seen as the name of a command by
+ * Tcl_Eval, proc will be called. To support the bytecode interpreter,
+ * the command is created with a wrapper Tcl_ObjCmdProc
+ * (TclInvokeStringCommand) that eventially calls proc. When the
+ * command is deleted from the table, deleteProc will be called.
+ * See the manual entry for details on the calling sequence.
*
*----------------------------------------------------------------------
*/
Tcl_Command
Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
- Tcl_Interp *interp; /* Token for command interpreter (returned
- * by a previous call to Tcl_CreateInterp). */
- char *cmdName; /* Name of command. */
- Tcl_CmdProc *proc; /* Command procedure to associate with
- * cmdName. */
- ClientData clientData; /* Arbitrary one-word value to pass to proc. */
+ Tcl_Interp *interp; /* Token for command interpreter returned by
+ * a previous call to Tcl_CreateInterp. */
+ char *cmdName; /* Name of command. If it contains namespace
+ * qualifiers, the new command is put in the
+ * specified namespace; otherwise it is put
+ * in the global namespace. */
+ Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */
+ ClientData clientData; /* Arbitrary value passed to string proc. */
Tcl_CmdDeleteProc *deleteProc;
- /* If not NULL, gives a procedure to call when
- * this command is deleted. */
+ /* If not NULL, gives a procedure to call
+ * when this command is deleted. */
{
Interp *iPtr = (Interp *) interp;
+ Namespace *nsPtr, *dummy1, *dummy2;
Command *cmdPtr;
Tcl_HashEntry *hPtr;
- int new;
+ char *tail;
+ int new, result;
+
+ if (iPtr->flags & DELETED) {
+ /*
+ * The interpreter is being deleted. Don't create any new
+ * commands; it's not safe to muck with the interpreter anymore.
+ */
+
+ return (Tcl_Command) NULL;
+ }
+
+ /*
+ * Determine where the command should reside. If its name contains
+ * namespace qualifiers, we put it in the specified namespace;
+ * otherwise, we always put it in the global namespace.
+ */
+ if (strstr(cmdName, "::") != NULL) {
+ result = TclGetNamespaceForQualName(interp, cmdName,
+ (Namespace *) NULL, CREATE_NS_IF_UNKNOWN, &nsPtr,
+ &dummy1, &dummy2, &tail);
+ if ((result != TCL_OK) || (nsPtr == NULL) || (tail == NULL)) {
+ return (Tcl_Command) NULL;
+ }
+ } else {
+ nsPtr = iPtr->globalNsPtr;
+ tail = cmdName;
+ }
+
/*
* The code below was added in 11/95 to preserve backwards compatibility
* when "tkerror" was renamed "bgerror": if anyone attempts to define
@@ -826,12 +1428,126 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
* code should eventually be removed.
*/
- if ((cmdName[0] == 't') && (strcmp(cmdName, "tkerror") == 0)) {
- cmdName = "bgerror";
+ if ((*tail == 't') && (strcmp(tail, "tkerror") == 0)
+ && (nsPtr == iPtr->globalNsPtr)) {
+ tail = "bgerror";
}
- if (iPtr->flags & DELETED) {
+ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
+ if (!new) {
+ /*
+ * Command already exists. Delete the old one.
+ */
+
+ cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
+ Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
+ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
+ if (!new) {
+ /*
+ * If the deletion callback recreated the command, just throw
+ * away the new command (if we try to delete it again, we
+ * could get stuck in an infinite loop).
+ */
+
+ ckfree((char*) cmdPtr);
+ }
+ }
+ cmdPtr = (Command *) ckalloc(sizeof(Command));
+ Tcl_SetHashValue(hPtr, cmdPtr);
+ cmdPtr->hPtr = hPtr;
+ cmdPtr->nsPtr = nsPtr;
+ cmdPtr->refCount = 1;
+ cmdPtr->cmdEpoch = 0;
+ cmdPtr->compileProc = (CompileProc *) NULL;
+ cmdPtr->objProc = TclInvokeStringCommand;
+ cmdPtr->objClientData = (ClientData) cmdPtr;
+ cmdPtr->proc = proc;
+ cmdPtr->clientData = clientData;
+ cmdPtr->deleteProc = deleteProc;
+ cmdPtr->deleteData = clientData;
+ cmdPtr->deleted = 0;
+ cmdPtr->importRefPtr = NULL;
+ /*
+ * The code below provides more backwards compatibility for the
+ * renaming of "tkerror" to "bgerror". Like the code above, this
+ * code should eventually become unnecessary.
+ */
+
+ if ((*tail == 'b') && (strcmp(tail, "bgerror") == 0)
+ && (nsPtr == iPtr->globalNsPtr)) {
+ /*
+ * We're currently creating the "bgerror" command; create
+ * a "tkerror" command that shares the same Command structure.
+ */
+
+ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, "tkerror", &new);
+ Tcl_SetHashValue(hPtr, cmdPtr);
+ }
+
+ /*
+ * We just created a command, so in its namespace and all of its parent
+ * namespaces, it may shadow global commands with the same name. If any
+ * shadowed commands are found, invalidate all cached command references
+ * in the affected namespaces.
+ */
+
+ TclResetShadowedCmdRefs(interp, cmdPtr);
+ return (Tcl_Command) cmdPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CreateObjCommand --
+ *
+ * Define a new object-based command in a command table.
+ *
+ * Results:
+ * The return value is a token for the command, which can
+ * be used in future calls to Tcl_NameOfCommand.
+ *
+ * Side effects:
+ * If no command named "cmdName" already exists for interp, one is
+ * created. Otherwise, if a command does exist, then if the
+ * object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume
+ * Tcl_CreateCommand was called previously for the same command and
+ * just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we
+ * delete the old command.
+ *
+ * In the future, during bytecode evaluation when "cmdName" is seen as
+ * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based
+ * Tcl_ObjCmdProc proc will be called. When the command is deleted from
+ * the table, deleteProc will be called. See the manual entry for
+ * details on the calling sequence.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
+ Tcl_Interp *interp; /* Token for command interpreter (returned
+ * by previous call to Tcl_CreateInterp). */
+ char *cmdName; /* Name of command. If it contains namespace
+ * qualifiers, the new command is put in the
+ * specified namespace; otherwise it is put
+ * in the global namespace. */
+ Tcl_ObjCmdProc *proc; /* Object-based procedure to associate with
+ * name. */
+ ClientData clientData; /* Arbitrary value to pass to object
+ * procedure. */
+ Tcl_CmdDeleteProc *deleteProc;
+ /* If not NULL, gives a procedure to call
+ * when this command is deleted. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Namespace *nsPtr, *dummy1, *dummy2;
+ Command *cmdPtr;
+ Tcl_HashEntry *hPtr;
+ char *tail;
+ int new, result;
+
+ if (iPtr->flags & DELETED) {
/*
* The interpreter is being deleted. Don't create any new
* commands; it's not safe to muck with the interpreter anymore.
@@ -839,46 +1555,98 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
return (Tcl_Command) NULL;
}
- hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new);
+
+ /*
+ * Determine where the command should reside. If its name contains
+ * namespace qualifiers, we put it in the specified namespace;
+ * otherwise, we always put it in the global namespace.
+ */
+
+ if (strstr(cmdName, "::") != NULL) {
+ result = TclGetNamespaceForQualName(interp, cmdName,
+ (Namespace *) NULL, CREATE_NS_IF_UNKNOWN, &nsPtr,
+ &dummy1, &dummy2, &tail);
+ if ((result != TCL_OK) || (nsPtr == NULL) || (tail == NULL)) {
+ return (Tcl_Command) NULL;
+ }
+ } else {
+ nsPtr = iPtr->globalNsPtr;
+ tail = cmdName;
+ }
+
+ /*
+ * The code below was added in 11/95 to preserve backwards compatibility
+ * when "tkerror" was renamed "bgerror": if anyone attempts to define
+ * "tkerror" as a command, it is actually created as "bgerror". This
+ * code should eventually be removed.
+ */
+
+ if ((*tail == 't') && (strcmp(tail, "tkerror") == 0)
+ && (nsPtr == iPtr->globalNsPtr)) {
+ tail = "bgerror";
+ }
+
+ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
if (!new) {
+ cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
+
/*
- * Command already exists: delete the old one.
+ * Command already exists. If its object-based Tcl_ObjCmdProc is
+ * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the
+ * argument "proc". Otherwise, we delete the old command.
*/
- Tcl_DeleteCommand(interp, Tcl_GetHashKey(&iPtr->commandTable, hPtr));
- hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new);
+ if (cmdPtr->objProc == TclInvokeStringCommand) {
+ cmdPtr->objProc = proc;
+ cmdPtr->objClientData = clientData;
+ cmdPtr->deleteProc = deleteProc;
+ cmdPtr->deleteData = clientData;
+ goto checkForBgerror;
+ }
+
+ Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
+ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
if (!new) {
/*
- * Drat. The stupid deletion callback recreated the command.
- * Just throw away the new command (if we try to delete it again,
- * we could get stuck in an infinite loop).
+ * If the deletion callback recreated the command, just throw
+ * away the new command (if we try to delete it again, we
+ * could get stuck in an infinite loop).
*/
- ckfree((char *) Tcl_GetHashValue(hPtr));
- }
+ ckfree((char *) Tcl_GetHashValue(hPtr));
+ }
}
cmdPtr = (Command *) ckalloc(sizeof(Command));
Tcl_SetHashValue(hPtr, cmdPtr);
cmdPtr->hPtr = hPtr;
- cmdPtr->proc = proc;
- cmdPtr->clientData = clientData;
+ cmdPtr->nsPtr = nsPtr;
+ cmdPtr->refCount = 1;
+ cmdPtr->cmdEpoch = 0;
+ cmdPtr->compileProc = (CompileProc *) NULL;
+ cmdPtr->objProc = proc;
+ cmdPtr->objClientData = clientData;
+ cmdPtr->proc = TclInvokeObjectCommand;
+ cmdPtr->clientData = (ClientData) cmdPtr;
cmdPtr->deleteProc = deleteProc;
cmdPtr->deleteData = clientData;
cmdPtr->deleted = 0;
-
+ cmdPtr->importRefPtr = NULL;
+
/*
* The code below provides more backwards compatibility for the
* renaming of "tkerror" to "bgerror". Like the code above, this
* code should eventually become unnecessary.
*/
- if ((cmdName[0] == 'b') && (strcmp(cmdName, "bgerror") == 0)) {
+ checkForBgerror:
+ if ((*tail == 'b') && (strcmp(tail, "bgerror") == 0)
+ && (nsPtr == iPtr->globalNsPtr)) {
/*
- * We're currently creating the "bgerror" command; create
+ * We're currently creating the "bgerror" command; create
* a "tkerror" command that shares the same Command structure.
*/
- hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, "tkerror", &new);
+ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, "tkerror", &new);
Tcl_SetHashValue(hPtr, cmdPtr);
}
return (Tcl_Command) cmdPtr;
@@ -887,15 +1655,378 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
/*
*----------------------------------------------------------------------
*
+ * TclInvokeStringCommand --
+ *
+ * "Wrapper" Tcl_ObjCmdProc used to call an existing string-based
+ * Tcl_CmdProc if no object-based procedure exists for a command. A
+ * pointer to this procedure is stored as the Tcl_ObjCmdProc in a
+ * Command structure. It simply turns around and calls the string
+ * Tcl_CmdProc in the Command structure.
+ *
+ * Results:
+ * A standard Tcl object result value.
+ *
+ * Side effects:
+ * Besides those side effects of the called Tcl_CmdProc,
+ * TclInvokeStringCommand allocates and frees storage.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclInvokeStringCommand(clientData, interp, objc, objv)
+ ClientData clientData; /* Points to command's Command structure. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ register int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ register Command *cmdPtr = (Command *) clientData;
+ register int i;
+ int result;
+
+ /*
+ * This procedure generates an argv array for the string arguments. It
+ * starts out with stack-allocated space but uses dynamically-allocated
+ * storage if needed.
+ */
+
+#define NUM_ARGS 20
+ char *(argStorage[NUM_ARGS]);
+ char **argv = argStorage;
+
+ /*
+ * Create the string argument array "argv". Make sure argv is large
+ * enough to hold the objc arguments plus 1 extra for the zero
+ * end-of-argv word.
+ * THIS FAILS IF ANY ARGUMENT OBJECT CONTAINS AN EMBEDDED NULL.
+ */
+
+ if ((objc + 1) > NUM_ARGS) {
+ argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
+ }
+
+ for (i = 0; i < objc; i++) {
+ argv[i] = Tcl_GetStringFromObj(objv[i], (int *) NULL);
+ }
+ argv[objc] = 0;
+
+ /*
+ * Invoke the command's string-based Tcl_CmdProc.
+ */
+
+ result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv);
+
+ /*
+ * Free the argv array if malloc'ed storage was used.
+ */
+
+ if (argv != argStorage) {
+ ckfree((char *) argv);
+ }
+ return result;
+#undef NUM_ARGS
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInvokeObjectCommand --
+ *
+ * "Wrapper" Tcl_CmdProc used to call an existing object-based
+ * Tcl_ObjCmdProc if no string-based procedure exists for a command.
+ * A pointer to this procedure is stored as the Tcl_CmdProc in a
+ * Command structure. It simply turns around and calls the object
+ * Tcl_ObjCmdProc in the Command structure.
+ *
+ * Results:
+ * A standard Tcl string result value.
+ *
+ * Side effects:
+ * Besides those side effects of the called Tcl_CmdProc,
+ * TclInvokeStringCommand allocates and frees storage.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclInvokeObjectCommand(clientData, interp, argc, argv)
+ ClientData clientData; /* Points to command's Command structure. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ register char **argv; /* Argument strings. */
+{
+ Command *cmdPtr = (Command *) clientData;
+ register Tcl_Obj *objPtr;
+ register int i;
+ int length, result;
+
+ /*
+ * This procedure generates an objv array for object arguments that hold
+ * the argv strings. It starts out with stack-allocated space but uses
+ * dynamically-allocated storage if needed.
+ */
+
+#define NUM_ARGS 20
+ Tcl_Obj *(argStorage[NUM_ARGS]);
+ register Tcl_Obj **objv = argStorage;
+
+ /*
+ * Create the object argument array "objv". Make sure objv is large
+ * enough to hold the objc arguments plus 1 extra for the zero
+ * end-of-objv word.
+ */
+
+ if ((argc + 1) > NUM_ARGS) {
+ objv = (Tcl_Obj **)
+ ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
+ }
+
+ for (i = 0; i < argc; i++) {
+ length = strlen(argv[i]);
+ TclNewObj(objPtr);
+ TclInitStringRep(objPtr, argv[i], length);
+ Tcl_IncrRefCount(objPtr);
+ objv[i] = objPtr;
+ }
+ objv[argc] = 0;
+
+ /*
+ * Invoke the command's object-based Tcl_ObjCmdProc.
+ */
+
+ result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv);
+
+ /*
+ * Move the interpreter's object result to the string result,
+ * then reset the object result.
+ * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULL BYTES.
+ */
+
+ Tcl_SetResult(interp,
+ TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
+ TCL_VOLATILE);
+
+ /*
+ * Decrement the ref counts for the argument objects created above,
+ * then free the objv array if malloc'ed storage was used.
+ */
+
+ for (i = 0; i < argc; i++) {
+ objPtr = objv[i];
+ Tcl_DecrRefCount(objPtr);
+ }
+ if (objv != argStorage) {
+ ckfree((char *) objv);
+ }
+ return result;
+#undef NUM_ARGS
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclRenameCommand --
+ *
+ * Called to give an existing Tcl command a different name. Both the
+ * old command name and the new command name can have "::" namespace
+ * qualifiers. If the new command has a different namespace context,
+ * the command is automatically moved to that namespace.
+ *
+ * If the new command name is NULL or the null string, the command is
+ * deleted.
+ *
+ * Results:
+ * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
+ *
+ * Side effects:
+ * If anything goes wrong, an error message is returned in the
+ * interpreter's result object.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclRenameCommand(interp, oldName, newName)
+ Tcl_Interp *interp; /* Current interpreter. */
+ char *oldName; /* Existing command name. */
+ char *newName; /* New command name. */
+{
+ Interp *iPtr = (Interp *) interp;
+ char *cmdTail, *newTail;
+ Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2;
+ Tcl_Command cmd;
+ Command *cmdPtr;
+ Tcl_HashEntry *hPtr, *oldHPtr;
+ int new, isSrcBgerror, isDestBgerror, result;
+
+ /*
+ * Find the existing command. An error is returned if cmdName can't
+ * be found.
+ */
+
+ cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL,
+ /*flags*/ 0);
+ cmdPtr = (Command *) cmd;
+ if (cmdPtr == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ",
+ ((newName == NULL) || (*newName == '\0'))? "delete":"rename",
+ " \"", oldName, "\": command doesn't exist", (char *) NULL);
+ return TCL_ERROR;
+ }
+ cmdTail = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
+ cmdNsPtr = cmdPtr->nsPtr;
+
+ /*
+ * If the new command name is NULL or empty, delete the command. Do this
+ * with Tcl_DeleteCommandFromToken, since we already have the command.
+ */
+
+ if ((newName == NULL) || (*newName == '\0')) {
+ Tcl_DeleteCommandFromToken(interp, cmd);
+ return TCL_OK;
+ }
+
+ /*
+ * Make sure that the destination command does not already exist.
+ * The rename operation is like creating a command, so we should
+ * automatically create the containing namespaces just like
+ * Tcl_CreateCommand would.
+ */
+
+ result = TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL,
+ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
+ &newNsPtr, &dummy1, &dummy2, &newTail);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if ((newNsPtr == NULL) || (newTail == NULL)) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "can't rename to \"", newName, "\": bad command name",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "can't rename to \"", newName,
+ "\": command already exists", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * The code below was added in 11/95 to preserve backwards compatibility
+ * when "tkerror" was renamed "bgerror": we guarantee that the hash
+ * table entries for both commands refer to a single shared Command
+ * structure. This code should eventually become unnecessary.
+ */
+
+ if ((*cmdTail == 't') && (strcmp(cmdTail, "tkerror") == 0)
+ && (cmdNsPtr == iPtr->globalNsPtr)) {
+ cmdTail = "bgerror";
+ }
+ isSrcBgerror = ((*cmdTail == 'b') && (strcmp(cmdTail, "bgerror") == 0)
+ && (cmdNsPtr == iPtr->globalNsPtr));
+
+ if ((*newTail == 't') && (strcmp(newTail, "tkerror") == 0)
+ && (newNsPtr == iPtr->globalNsPtr)) {
+ newTail = "bgerror";
+ }
+ isDestBgerror = ((*newTail == 'b') && (strcmp(newTail, "bgerror") == 0)
+ && (newNsPtr == iPtr->globalNsPtr));
+
+ /*
+ * Put the command in the new namespace, so we can check for an alias
+ * loop. Since we are adding a new command to a namespace, we must
+ * handle any shadowing of the global commands that this might create.
+ * Note that the renamed command has a different hashtable pointer than
+ * it used to have. This allows the command caching code in tclExecute.c
+ * to recognize that a command pointer it has cached for this command is
+ * now invalid.
+ */
+
+ oldHPtr = cmdPtr->hPtr;
+ hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new);
+ Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
+ cmdPtr->hPtr = hPtr;
+ cmdPtr->nsPtr = newNsPtr;
+ TclResetShadowedCmdRefs(interp, cmdPtr);
+
+ /*
+ * Everything is in place so we can check for an alias loop. If we
+ * detect one, put everything back the way it was and report the error.
+ */
+
+ result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr);
+ if (result != TCL_OK) {
+ Tcl_DeleteHashEntry(cmdPtr->hPtr);
+ cmdPtr->hPtr = oldHPtr;
+ cmdPtr->nsPtr = cmdNsPtr;
+ return result;
+ }
+
+ /*
+ * The new command name is okay, so remove the command from its
+ * current namespace. This is like deleting the command, so bump
+ * the cmdEpoch to invalidate any cached references to the command.
+ */
+
+ Tcl_DeleteHashEntry(oldHPtr);
+ cmdPtr->cmdEpoch++;
+
+ /*
+ * If the command being renamed has a compile procedure, increment the
+ * interpreter's compileEpoch to invalidate its compiled code. This
+ * makes sure that we don't later try to execute old code compiled for
+ * the now-renamed command.
+ */
+
+ if (cmdPtr->compileProc != NULL) {
+ iPtr->compileEpoch++;
+ }
+
+ /*
+ * The code below provides more backwards compatibility for the
+ * "tkerror" => "bgerror" renaming. As with the other compatibility
+ * code above, it should eventually be removed.
+ */
+
+ if (isSrcBgerror) {
+ /*
+ * The source command is "bgerror": delete the hash table entry for
+ * "tkerror" if it exists.
+ */
+
+ hPtr = Tcl_FindHashEntry(&cmdNsPtr->cmdTable, "tkerror");
+ if (hPtr != NULL) {
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ }
+ if (isDestBgerror) {
+ /*
+ * The destination command is "bgerror"; create a "tkerror"
+ * command that shares the same Command structure.
+ */
+
+ hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, "tkerror", &new);
+ Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_SetCommandInfo --
*
- * Modifies various information about a Tcl command.
+ * Modifies various information about a Tcl command. Note that
+ * this procedure will not change a command's namespace; use
+ * Tcl_RenameCommand to do that. Also, the isNativeObjectProc
+ * member of *infoPtr is ignored.
*
* Results:
* If cmdName exists in interp, then the information at *infoPtr
* is stored with the command in place of the current information
- * and 1 is returned. If the command doesn't exist then 0 is
- * returned.
+ * and 1 is returned. If the command doesn't exist then 0 is
+ * returned.
*
* Side effects:
* None.
@@ -911,16 +2042,29 @@ Tcl_SetCommandInfo(interp, cmdName, infoPtr)
Tcl_CmdInfo *infoPtr; /* Where to store information about
* command. */
{
- Tcl_HashEntry *hPtr;
+ Tcl_Command cmd;
Command *cmdPtr;
- hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName);
- if (hPtr == NULL) {
+ cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
+ /*flags*/ 0);
+ if (cmd == (Tcl_Command) NULL) {
return 0;
}
- cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
+
+ /*
+ * The isNativeObjectProc and nsPtr members of *infoPtr are ignored.
+ */
+
+ cmdPtr = (Command *) cmd;
cmdPtr->proc = infoPtr->proc;
cmdPtr->clientData = infoPtr->clientData;
+ if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
+ cmdPtr->objProc = TclInvokeStringCommand;
+ cmdPtr->objClientData = (ClientData) cmdPtr;
+ } else {
+ cmdPtr->objProc = infoPtr->objProc;
+ cmdPtr->objClientData = infoPtr->objClientData;
+ }
cmdPtr->deleteProc = infoPtr->deleteProc;
cmdPtr->deleteData = infoPtr->deleteData;
return 1;
@@ -953,18 +2097,30 @@ Tcl_GetCommandInfo(interp, cmdName, infoPtr)
Tcl_CmdInfo *infoPtr; /* Where to store information about
* command. */
{
- Tcl_HashEntry *hPtr;
+ Tcl_Command cmd;
Command *cmdPtr;
- hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName);
- if (hPtr == NULL) {
+ cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
+ /*flags*/ 0);
+ if (cmd == (Tcl_Command) NULL) {
return 0;
}
- cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
+
+ /*
+ * Set isNativeObjectProc 1 if objProc was registered by a call to
+ * Tcl_CreateObjCommand. Otherwise set it to 0.
+ */
+
+ cmdPtr = (Command *) cmd;
+ infoPtr->isNativeObjectProc =
+ (cmdPtr->objProc != TclInvokeStringCommand);
+ infoPtr->objProc = cmdPtr->objProc;
+ infoPtr->objClientData = cmdPtr->objClientData;
infoPtr->proc = cmdPtr->proc;
infoPtr->clientData = cmdPtr->clientData;
infoPtr->deleteProc = cmdPtr->deleteProc;
infoPtr->deleteData = cmdPtr->deleteData;
+ infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
return 1;
}
@@ -989,24 +2145,76 @@ Tcl_GetCommandInfo(interp, cmdName, infoPtr)
char *
Tcl_GetCommandName(interp, command)
Tcl_Interp *interp; /* Interpreter containing the command. */
- Tcl_Command command; /* Token for the command, returned by a
- * previous call to Tcl_CreateCommand.
- * The command must not have been deleted. */
+ Tcl_Command command; /* Token for command returned by a previous
+ * call to Tcl_CreateCommand. The command
+ * must not have been deleted. */
{
Command *cmdPtr = (Command *) command;
- Interp *iPtr = (Interp *) interp;
if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) {
/*
* This should only happen if command was "created" after the
* interpreter began to be deleted, so there isn't really any
- * command. Just return an empty string.
+ * command. Just return an empty string.
*/
return "";
}
- return Tcl_GetHashKey(&iPtr->commandTable, cmdPtr->hPtr);
+ return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetCommandFullName --
+ *
+ * Given a token returned by, e.g., Tcl_CreateCommand or
+ * Tcl_FindCommand, this procedure appends to an object the command's
+ * full name, qualified by a sequence of parent namespace names. The
+ * command's fully-qualified name may have changed due to renaming.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The command's fully-qualified name is appended to the string
+ * representation of objPtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_GetCommandFullName(interp, command, objPtr)
+ Tcl_Interp *interp; /* Interpreter containing the command. */
+ Tcl_Command command; /* Token for command returned by a previous
+ * call to Tcl_CreateCommand. The command
+ * must not have been deleted. */
+ Tcl_Obj *objPtr; /* Points to the object onto which the
+ * command's full name is appended. */
+
+{
+ Interp *iPtr = (Interp *) interp;
+ register Command *cmdPtr = (Command *) command;
+ char *name;
+
+ /*
+ * Add the full name of the containing namespace, followed by the "::"
+ * separator, and the command name.
+ */
+
+ if (cmdPtr != NULL) {
+ if (cmdPtr->nsPtr != NULL) {
+ Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
+ if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
+ Tcl_AppendToObj(objPtr, "::", 2);
+ }
+ }
+ if (cmdPtr->hPtr != NULL) {
+ name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
+ Tcl_AppendToObj(objPtr, name, -1);
+ }
+ }
}
/*
@@ -1018,11 +2226,10 @@ Tcl_GetCommandName(interp, command)
*
* Results:
* 0 is returned if the command was deleted successfully.
- * -1 is returned if there didn't exist a command by that
- * name.
+ * -1 is returned if there didn't exist a command by that name.
*
* Side effects:
- * CmdName will no longer be recognized as a valid command for
+ * cmdName will no longer be recognized as a valid command for
* interp.
*
*----------------------------------------------------------------------
@@ -1031,40 +2238,71 @@ Tcl_GetCommandName(interp, command)
int
Tcl_DeleteCommand(interp, cmdName)
Tcl_Interp *interp; /* Token for command interpreter (returned
- * by a previous call to Tcl_CreateInterp). */
+ * by a previous Tcl_CreateInterp call). */
char *cmdName; /* Name of command to remove. */
{
- Interp *iPtr = (Interp *) interp;
- Tcl_HashEntry *hPtr, *tkErrorHPtr;
- Command *cmdPtr;
+ Tcl_Command cmd;
/*
- * The code below was added in 11/95 to preserve backwards compatibility
- * when "tkerror" was renamed "bgerror": if anyone attempts to delete
- * "tkerror", delete both it and "bgerror". This code should
- * eventually be removed.
+ * Find the desired command and delete it.
*/
- if ((cmdName[0] == 't') && (strcmp(cmdName, "tkerror") == 0)) {
- cmdName = "bgerror";
- }
- hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName);
- if (hPtr == NULL) {
+ cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
+ /*flags*/ 0);
+ if (cmd == (Tcl_Command) NULL) {
return -1;
}
- cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
+ return Tcl_DeleteCommandFromToken(interp, cmd);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DeleteCommandFromToken --
+ *
+ * Removes the given command from the given interpreter. This procedure
+ * resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead
+ * of a command name for efficiency.
+ *
+ * Results:
+ * 0 is returned if the command was deleted successfully.
+ * -1 is returned if there didn't exist a command by that name.
+ *
+ * Side effects:
+ * The command specified by "cmd" will no longer be recognized as a
+ * valid command for "interp".
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_DeleteCommandFromToken(interp, cmd)
+ Tcl_Interp *interp; /* Token for command interpreter returned by
+ * a previous call to Tcl_CreateInterp. */
+ Tcl_Command cmd; /* Token for command to delete. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Command *cmdPtr = (Command *) cmd;
+ char *cmdName;
+ int isBgerror;
+ ImportRef *refPtr, *nextRefPtr;
+ Tcl_Command importCmd;
+ Tcl_HashEntry *tkErrorHPtr;
+
+ cmdName = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
+ isBgerror = ((*cmdName == 'b') && (strcmp(cmdName, "bgerror") == 0)
+ && (cmdPtr->nsPtr == iPtr->globalNsPtr));
/*
* The code here is tricky. We can't delete the hash table entry
* before invoking the deletion callback because there are cases
* where the deletion callback needs to invoke the command (e.g.
- * object systems such as OTcl). However, this means that the
- * callback could try to delete or rename the command. The deleted
+ * object systems such as OTcl). However, this means that the
+ * callback could try to delete or rename the command. The deleted
* flag allows us to detect these cases and skip nested deletes.
*/
if (cmdPtr->deleted) {
-
/*
* Another deletion is already in progress. Remove the hash
* table entry now, but don't invoke a callback or free the
@@ -1075,19 +2313,59 @@ Tcl_DeleteCommand(interp, cmdName)
cmdPtr->hPtr = NULL;
return 0;
}
+
+ /*
+ * If the command being deleted has a compile procedure, increment the
+ * interpreter's compileEpoch to invalidate its compiled code. This
+ * makes sure that we don't later try to execute old code compiled with
+ * command-specific (i.e., inline) bytecodes for the now-deleted
+ * command. This field is checked in Tcl_EvalObj and ObjInterpProc, and
+ * code whose compilation epoch doesn't match is recompiled.
+ */
+
+ if (cmdPtr->compileProc != NULL) {
+ iPtr->compileEpoch++;
+ }
+
cmdPtr->deleted = 1;
if (cmdPtr->deleteProc != NULL) {
+ /*
+ * Delete the command's client data. If this was an imported command
+ * created when a command was imported into a namespace, this client
+ * data will be a pointer to a ImportedCmdData structure describing
+ * the "real" command that this imported command refers to.
+ */
+
(*cmdPtr->deleteProc)(cmdPtr->deleteData);
}
/*
+ * Bump the command epoch counter. This will invalidate all cached
+ * references that point to this command.
+ */
+
+ cmdPtr->cmdEpoch++;
+
+ /*
+ * If this command was imported into other namespaces, then imported
+ * commands were created that refer back to this command. Delete these
+ * imported commands now.
+ */
+
+ for (refPtr = cmdPtr->importRefPtr; refPtr != NULL;
+ refPtr = nextRefPtr) {
+ nextRefPtr = refPtr->nextPtr;
+ importCmd = (Tcl_Command) refPtr->importedCmdPtr;
+ Tcl_DeleteCommandFromToken(interp, importCmd);
+ }
+
+ /*
* The code below provides more backwards compatibility for the
- * renaming of "tkerror" to "bgerror". Like the code above, this
+ * renaming of "tkerror" to "bgerror". Like the code above, this
* code should eventually become unnecessary.
*/
- if ((cmdName[0] == 'b') && (strcmp(cmdName, "bgerror") == 0)) {
-
+ if (isBgerror) {
/*
* When the "bgerror" command is deleted, delete "tkerror"
* as well. It shared the same Command structure as "bgerror",
@@ -1096,7 +2374,9 @@ Tcl_DeleteCommand(interp, cmdName)
* been deleted before bgerror.
*/
- tkErrorHPtr = Tcl_FindHashEntry(&iPtr->commandTable, "tkerror");
+ tkErrorHPtr = Tcl_FindHashEntry(cmdPtr->hPtr->tablePtr,
+ "tkerror");
+
if (tkErrorHPtr != (Tcl_HashEntry *) NULL) {
Tcl_DeleteHashEntry(tkErrorHPtr);
}
@@ -1112,117 +2392,187 @@ Tcl_DeleteCommand(interp, cmdName)
if (cmdPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(cmdPtr->hPtr);
}
- ckfree((char *) cmdPtr);
+ /*
+ * Mark the Command structure as no longer valid. This allows
+ * TclExecuteByteCode to recognize when a Command has logically been
+ * deleted and a pointer to this Command structure cached in a CmdName
+ * object is invalid. TclExecuteByteCode will look up the command again
+ * in the interpreter's command hashtable.
+ */
+
+ cmdPtr->objProc = NULL;
+
+ /*
+ * Now free the Command structure, unless there is another reference to
+ * it from a CmdName Tcl object in some ByteCode code sequence. In that
+ * case, delay the cleanup until all references are either discarded
+ * (when a ByteCode is freed) or replaced by a new reference (when a
+ * cached CmdName Command reference is found to be invalid and
+ * TclExecuteByteCode looks up the command in the command hashtable).
+ */
+
+ TclCleanupCommand(cmdPtr);
return 0;
}
/*
- *-----------------------------------------------------------------
+ *----------------------------------------------------------------------
+ *
+ * TclCleanupCommand --
+ *
+ * This procedure frees up a Command structure unless it is still
+ * referenced from an interpreter's command hashtable or from a CmdName
+ * Tcl object representing the name of a command in a ByteCode
+ * instruction sequence.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory gets freed unless a reference to the Command structure still
+ * exists. In that case the cleanup is delayed until the command is
+ * deleted or when the last ByteCode referring to it is freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclCleanupCommand(cmdPtr)
+ register Command *cmdPtr; /* Points to the Command structure to
+ * be freed. */
+{
+ cmdPtr->refCount--;
+ if (cmdPtr->refCount <= 0) {
+ ckfree((char *) cmdPtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
*
* Tcl_Eval --
*
- * Parse and execute a command in the Tcl language.
+ * Execute a Tcl command in a string.
*
* Results:
- * The return value is one of the return codes defined in tcl.hd
+ * The return value is one of the return codes defined in tcl.h
* (such as TCL_OK), and interp->result contains a string value
- * to supplement the return code. The value of interp->result
- * will persist only until the next call to Tcl_Eval: copy it or
- * lose it! *TermPtr is filled in with the character just after
- * the last one that was part of the command (usually a NULL
- * character or a closing bracket).
+ * to supplement the return code. The value of interp->result
+ * will persist only until the next call to Tcl_Eval or Tcl_EvalObj:
+ * you must copy it or lose it!
*
* Side effects:
- * Almost certainly; depends on the command.
+ * The string is compiled to produce a ByteCode object that holds the
+ * command's bytecode instructions. However, this ByteCode object is
+ * lost after executing the command. The command's execution will
+ * almost certainly have side effects. interp->termOffset is set to the
+ * offset of the character in "string" just after the last one
+ * successfully compiled or executed.
*
- *-----------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
int
-Tcl_Eval(interp, cmd)
+Tcl_Eval(interp, string)
Tcl_Interp *interp; /* Token for command interpreter (returned
- * by a previous call to Tcl_CreateInterp). */
- char *cmd; /* Pointer to TCL command to interpret. */
+ * by previous call to Tcl_CreateInterp). */
+ char *string; /* Pointer to TCL command to execute. */
{
- /*
- * The storage immediately below is used to generate a copy
- * of the command, after all argument substitutions. Pv will
- * contain the argv values passed to the command procedure.
- */
+ register Tcl_Obj *cmdPtr;
+ int length = strlen(string);
+ int result;
-# define NUM_CHARS 200
- char copyStorage[NUM_CHARS];
- ParseValue pv;
- char *oldBuffer;
+ if (length > 0) {
+ /*
+ * Initialize a Tcl object from the command string.
+ */
- /*
- * This procedure generates an (argv, argc) array for the command,
- * It starts out with stack-allocated space but uses dynamically-
- * allocated storage to increase it if needed.
- */
+ TclNewObj(cmdPtr);
+ TclInitStringRep(cmdPtr, string, length);
+ Tcl_IncrRefCount(cmdPtr);
-# define NUM_ARGS 10
- char *(argStorage[NUM_ARGS]);
- char **argv = argStorage;
- int argc;
- int argSize = NUM_ARGS;
-
- register char *src; /* Points to current character
- * in cmd. */
- char termChar; /* Return when this character is found
- * (either ']' or '\0'). Zero means
- * that newlines terminate commands. */
+ /*
+ * Compile and execute the bytecodes.
+ */
+
+ result = Tcl_EvalObj(interp, cmdPtr);
+
+ /*
+ * Move the interpreter's object result to the string result,
+ * then reset the object result.
+ * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
+ */
+
+ Tcl_SetResult(interp,
+ TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
+ TCL_VOLATILE);
+
+ /*
+ * Discard the Tcl object created to hold the command and its code.
+ */
+
+ Tcl_DecrRefCount(cmdPtr);
+ } else {
+ /*
+ * An empty string. Just reset the interpreter's result.
+ */
+
+ Tcl_ResetResult(interp);
+ result = TCL_OK;
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_EvalObj --
+ *
+ * Execute Tcl commands stored in a Tcl object. These commands are
+ * compiled into bytecodes if necessary.
+ *
+ * Results:
+ * The return value is one of the return codes defined in tcl.h
+ * (such as TCL_OK), and the interpreter's result contains a value
+ * to supplement the return code.
+ *
+ * Side effects:
+ * The object is converted, if necessary, to a ByteCode object that
+ * holds the bytecode instructions for the commands. Executing the
+ * commands will almost certainly have side effects that depend
+ * on those commands.
+ *
+ * Just as in Tcl_Eval, interp->termOffset is set to the offset of the
+ * last character executed in the objPtr's string.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_EvalObj(interp, objPtr)
+ Tcl_Interp *interp; /* Token for command interpreter
+ * (returned by a previous call to
+ * Tcl_CreateInterp). */
+ Tcl_Obj *objPtr; /* Pointer to object containing
+ * commands to execute. */
+{
+ register Interp *iPtr = (Interp *) interp;
int flags; /* Interp->evalFlags value when the
* procedure was called. */
- int result; /* Return value. */
- register Interp *iPtr = (Interp *) interp;
- Tcl_HashEntry *hPtr;
- Command *cmdPtr;
- char *termPtr; /* Contains character just after the
- * last one in the command. */
- char *cmdStart; /* Points to first non-blank char. in
- * command (used in calling trace
- * procedures). */
- char *ellipsis = ""; /* Used in setting errorInfo variable;
- * set to "..." to indicate that not
- * all of offending command is included
- * in errorInfo. "" means that the
- * command is all there. */
- register Trace *tracePtr;
+ register ByteCode* codePtr; /* Tcl Internal type of bytecode. */
int oldCount = iPtr->cmdCount; /* Used to tell whether any commands
* at all were executed. */
+ int numSrcChars;
+ register int result;
/*
- * Initialize the result to an empty string and clear out any
- * error information. This makes sure that we return an empty
+ * Reset both the interpreter's string and object results and clear out
+ * any error information. This makes sure that we return an empty
* result if there are no commands in the command string.
*/
- Tcl_FreeResult((Tcl_Interp *) iPtr);
- iPtr->result = iPtr->resultSpace;
- iPtr->resultSpace[0] = 0;
- result = TCL_OK;
-
- /*
- * Initialize the area in which command copies will be assembled.
- */
-
- pv.buffer = copyStorage;
- pv.end = copyStorage + NUM_CHARS - 1;
- pv.expandProc = TclExpandParseValue;
- pv.clientData = (ClientData) NULL;
-
- src = cmd;
- flags = iPtr->evalFlags;
- iPtr->evalFlags = 0;
- if (flags & TCL_BRACKET_TERM) {
- termChar = ']';
- } else {
- termChar = 0;
- }
- termPtr = src;
- cmdStart = src;
+ Tcl_ResetResult(interp);
/*
* Check depth of nested calls to Tcl_Eval: if this gets too large,
@@ -1232,226 +2582,102 @@ Tcl_Eval(interp, cmd)
iPtr->numLevels++;
if (iPtr->numLevels > iPtr->maxNestingDepth) {
iPtr->numLevels--;
- iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)";
- iPtr->termPtr = termPtr;
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
return TCL_ERROR;
}
/*
- * There can be many sub-commands (separated by semi-colons or
- * newlines) in one command string. This outer loop iterates over
- * individual commands.
+ * If the interpreter has been deleted, return an error.
*/
+
+ if (iPtr->flags & DELETED) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "attempt to call eval in deleted interpreter", -1);
+ Tcl_SetErrorCode(interp, "CORE", "IDELETE",
+ "attempt to call eval in deleted interpreter", (char *) NULL);
+ iPtr->numLevels--;
+ return TCL_ERROR;
+ }
- while (*src != termChar) {
-
- /*
- * If we have been deleted, return an error preventing further
- * evals.
- */
-
- if (iPtr->flags & DELETED) {
- Tcl_ResetResult(interp);
- interp->result = "attempt to call eval in deleted interpreter";
- Tcl_SetErrorCode(interp, "CORE", "IDELETE", interp->result,
- (char *) NULL);
- iPtr->numLevels--;
- return TCL_ERROR;
- }
-
- iPtr->flags &= ~(ERR_IN_PROGRESS | ERROR_CODE_SET);
-
- /*
- * Skim off leading white space and semi-colons, and skip
- * comments.
- */
-
- while (1) {
- register char c = *src;
-
- if ((CHAR_TYPE(c) != TCL_SPACE) && (c != ';') && (c != '\n')) {
- break;
- }
- src += 1;
- }
- if (*src == '#') {
- while (*src != 0) {
- if (*src == '\\') {
- int length;
- Tcl_Backslash(src, &length);
- src += length;
- } else if (*src == '\n') {
- src++;
- termPtr = src;
- break;
- } else {
- src++;
- }
- }
- continue;
- }
- cmdStart = src;
-
- /*
- * Parse the words of the command, generating the argc and
- * argv for the command procedure. May have to call
- * TclParseWords several times, expanding the argv array
- * between calls.
- */
-
- pv.next = oldBuffer = pv.buffer;
- argc = 0;
- while (1) {
- int newArgs, maxArgs;
- char **newArgv;
- int i;
-
- /*
- * Note: the "- 2" below guarantees that we won't use the
- * last two argv slots here. One is for a NULL pointer to
- * mark the end of the list, and the other is to leave room
- * for inserting the command name "unknown" as the first
- * argument (see below).
- */
-
- maxArgs = argSize - argc - 2;
- result = TclParseWords((Tcl_Interp *) iPtr, src, flags,
- maxArgs, &termPtr, &newArgs, &argv[argc], &pv);
- src = termPtr;
- if (result != TCL_OK) {
- ellipsis = "...";
- goto done;
- }
-
- /*
- * Careful! Buffer space may have gotten reallocated while
- * parsing words. If this happened, be sure to update all
- * of the older argv pointers to refer to the new space.
- */
-
- if (oldBuffer != pv.buffer) {
- int i;
-
- for (i = 0; i < argc; i++) {
- argv[i] = pv.buffer + (argv[i] - oldBuffer);
- }
- oldBuffer = pv.buffer;
- }
- argc += newArgs;
- if (newArgs < maxArgs) {
- argv[argc] = (char *) NULL;
- break;
- }
-
- /*
- * Args didn't all fit in the current array. Make it bigger.
- */
-
- argSize *= 2;
- newArgv = (char **)
- ckalloc((unsigned) argSize * sizeof(char *));
- for (i = 0; i < argc; i++) {
- newArgv[i] = argv[i];
- }
- if (argv != argStorage) {
- ckfree((char *) argv);
- }
- argv = newArgv;
- }
-
- /*
- * If this is an empty command (or if we're just parsing
- * commands without evaluating them), then just skip to the
- * next command.
- */
+ /*
+ * Get the ByteCode from the object. If it exists, make sure it hasn't
+ * been invalidated by, e.g., someone redefining a command with a
+ * compile procedure (this might make the compiled code wrong). If
+ * necessary, convert the object to be a ByteCode object and compile it.
+ * Also, if the code was compiled in/for a different interpreter,
+ * we recompile it.
+ */
- if ((argc == 0) || iPtr->noEval) {
- continue;
+ if (objPtr->typePtr == &tclByteCodeType) {
+ codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+
+ if ((codePtr->iPtr != iPtr)
+ || (codePtr->compileEpoch != iPtr->compileEpoch)) {
+ tclByteCodeType.freeIntRepProc(objPtr);
}
- argv[argc] = NULL;
-
+ }
+ if (objPtr->typePtr != &tclByteCodeType) {
/*
- * Save information for the history module, if needed.
+ * First reset any error line number information.
*/
-
- if (flags & TCL_RECORD_BOUNDS) {
- iPtr->evalFirst = cmdStart;
- iPtr->evalLast = src-1;
+
+ iPtr->errorLine = 1; /* no correct line # information yet */
+ result = tclByteCodeType.setFromAnyProc(interp, objPtr);
+ if (result != TCL_OK) {
+ iPtr->numLevels--;
+ return result;
}
+ }
+ codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
- /*
- * Find the procedure to execute this command. If there isn't
- * one, then see if there is a command "unknown". If so,
- * invoke it instead, passing it the words of the original
- * command as arguments.
- */
-
- hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[0]);
- if (hPtr == NULL) {
- int i;
+ /*
+ * Extract then reset the compilation flags in the interpreter.
+ * Resetting the flags must be done after any compilation.
+ */
- hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "unknown");
- if (hPtr == NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "invalid command name \"",
- argv[0], "\"", (char *) NULL);
- result = TCL_ERROR;
- goto done;
- }
- for (i = argc; i >= 0; i--) {
- argv[i+1] = argv[i];
- }
- argv[0] = "unknown";
- argc++;
- }
- cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
+ flags = iPtr->evalFlags;
+ iPtr->evalFlags = 0;
- /*
- * Call trace procedures, if any.
- */
+ /*
+ * Save information for the history module, if needed.
+ * BTL: setting these NULL disables history revisions.
+ */
- for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
- tracePtr = tracePtr->nextPtr) {
- char saved;
+ if (flags & TCL_RECORD_BOUNDS) {
+ iPtr->evalFirst = NULL;
+ iPtr->evalLast = NULL;
+ }
- if (tracePtr->level < iPtr->numLevels) {
- continue;
- }
- saved = *src;
- *src = 0;
- (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
- cmdStart, cmdPtr->proc, cmdPtr->clientData, argc, argv);
- *src = saved;
- }
+ /*
+ * Execute the commands. If the code was compiled from an empty string,
+ * don't bother executing the code.
+ */
+ numSrcChars = codePtr->numSrcChars;
+ if (numSrcChars > 0) {
/*
- * At long last, invoke the command procedure. Reset the
- * result to its default empty value first (it could have
- * gotten changed by earlier commands in the same command
- * string).
+ * Increment the code's ref count while it is being executed. If
+ * afterwards no references to it remain, free the code.
*/
-
- iPtr->cmdCount++;
- Tcl_FreeResult(iPtr);
- iPtr->result = iPtr->resultSpace;
- iPtr->resultSpace[0] = 0;
- result = (*cmdPtr->proc)(cmdPtr->clientData, interp, argc, argv);
- if (Tcl_AsyncReady()) {
- result = Tcl_AsyncInvoke(interp, result);
- }
- if (result != TCL_OK) {
- break;
+
+ codePtr->refCount++;
+ result = TclExecuteByteCode(interp, codePtr);
+ codePtr->refCount--;
+ if (codePtr->refCount <= 0) {
+ TclCleanupByteCode(codePtr);
}
+ } else {
+ Tcl_ResetResult(interp);
+ result = TCL_OK;
}
- done:
-
/*
* If no commands at all were executed, check for asynchronous
* handlers so that they at least get one change to execute.
* This is needed to handle event loops written in Tcl with
- * empty bodies (I'm not sure that loops like this are a good
- * idea, * but...).
+ * empty bodies.
*/
if ((oldCount == iPtr->cmdCount) && (Tcl_AsyncReady())) {
@@ -1462,12 +2688,6 @@ Tcl_Eval(interp, cmd)
* Free up any extra resources that were allocated.
*/
- if (pv.buffer != copyStorage) {
- ckfree((char *) pv.buffer);
- }
- if (argv != argStorage) {
- ckfree((char *) argv);
- }
iPtr->numLevels--;
if (iPtr->numLevels == 0) {
if (result == TCL_RETURN) {
@@ -1477,13 +2697,15 @@ Tcl_Eval(interp, cmd)
&& !(flags & TCL_ALLOW_EXCEPTIONS)) {
Tcl_ResetResult(interp);
if (result == TCL_BREAK) {
- iPtr->result = "invoked \"break\" outside of a loop";
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "invoked \"break\" outside of a loop", -1);
} else if (result == TCL_CONTINUE) {
- iPtr->result = "invoked \"continue\" outside of a loop";
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "invoked \"continue\" outside of a loop", -1);
} else {
- iPtr->result = iPtr->resultSpace;
- sprintf(iPtr->resultSpace, "command returned bad code: %d",
- result);
+ char buf[50];
+ sprintf(buf, "command returned bad code: %d", result);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
}
result = TCL_ERROR;
}
@@ -1495,14 +2717,18 @@ Tcl_Eval(interp, cmd)
*/
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
- int numChars;
- register char *p;
+ char buf[200];
+ char *ellipsis = "";
+ char *bytes;
+ int length;
/*
* Compute the line number where the error occurred.
+ * BTL: no line # information yet.
*/
iPtr->errorLine = 1;
+#ifdef NOT_YET
for (p = cmd; p != cmdStart; p++) {
if (*p == '\n') {
iPtr->errorLine++;
@@ -1513,32 +2739,958 @@ Tcl_Eval(interp, cmd)
iPtr->errorLine++;
}
}
-
+#endif
+
/*
* Figure out how much of the command to print in the error
* message (up to a certain number of characters, or up to
* the first new-line).
+ * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL.
*/
- numChars = src - cmdStart;
- if (numChars > (NUM_CHARS-50)) {
- numChars = NUM_CHARS-50;
+ bytes = Tcl_GetStringFromObj(objPtr, &length);
+ length = TclMin(numSrcChars, length);
+ if (length > 150) {
+ length = 150;
ellipsis = " ...";
}
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
- sprintf(copyStorage, "\n while executing\n\"%.*s%s\"",
- numChars, cmdStart, ellipsis);
+ sprintf(buf, "\n while executing\n\"%.*s%s\"",
+ length, bytes, ellipsis);
} else {
- sprintf(copyStorage, "\n invoked from within\n\"%.*s%s\"",
- numChars, cmdStart, ellipsis);
+ sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
+ length, bytes, ellipsis);
}
- Tcl_AddErrorInfo(interp, copyStorage);
- iPtr->flags &= ~ERR_ALREADY_LOGGED;
+ Tcl_AddObjErrorInfo(interp, buf, -1);
+ }
+
+ /*
+ * Set the interpreter's termOffset member to the offset of the
+ * character just after the last one executed. We approximate the offset
+ * of the last character executed by using the number of characters
+ * compiled.
+ */
+
+ iPtr->termOffset = numSrcChars;
+ iPtr->flags &= ~ERR_ALREADY_LOGGED;
+ return result;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
+ *
+ * Procedures to evaluate an expression and return its value in a
+ * particular form.
+ *
+ * Results:
+ * Each of the procedures below returns a standard Tcl result. If an
+ * error occurs then an error message is left in interp->result.
+ * Otherwise the value of the expression, in the appropriate form, is
+ * stored at *ptr. If the expression had a result that was
+ * incompatible with the desired form then an error is returned.
+ *
+ * Side effects:
+ * None.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tcl_ExprLong(interp, string, ptr)
+ Tcl_Interp *interp; /* Context in which to evaluate the
+ * expression. */
+ char *string; /* Expression to evaluate. */
+ long *ptr; /* Where to store result. */
+{
+ register Tcl_Obj *exprPtr;
+ Tcl_Obj *resultPtr;
+ int length = strlen(string);
+ int result = TCL_OK;
+
+ if (length > 0) {
+ exprPtr = Tcl_NewStringObj(string, length);
+ Tcl_IncrRefCount(exprPtr);
+
+ result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
+ if (result == TCL_OK) {
+ /*
+ * Store an integer based on the expression result.
+ */
+
+ if (resultPtr->typePtr == &tclIntType) {
+ *ptr = resultPtr->internalRep.longValue;
+ } else if (resultPtr->typePtr == &tclDoubleType) {
+ *ptr = (long) resultPtr->internalRep.doubleValue;
+ } else {
+ Tcl_SetResult(interp,
+ "expression didn't have numeric value", TCL_STATIC);
+ result = TCL_ERROR;
+ }
+ Tcl_DecrRefCount(resultPtr); /* discard the result object */
+ } else {
+ /*
+ * Move the interpreter's object result to the string result,
+ * then reset the object result.
+ * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
+ */
+
+ Tcl_SetResult(interp,
+ TclGetStringFromObj(Tcl_GetObjResult(interp),
+ (int *) NULL),
+ TCL_VOLATILE);
+ }
+ Tcl_DecrRefCount(exprPtr); /* discard the expression object */
+ } else {
+ /*
+ * An empty string. Just set the result integer to 0.
+ */
+
+ *ptr = 0;
+ }
+ return result;
+}
+
+int
+Tcl_ExprDouble(interp, string, ptr)
+ Tcl_Interp *interp; /* Context in which to evaluate the
+ * expression. */
+ char *string; /* Expression to evaluate. */
+ double *ptr; /* Where to store result. */
+{
+ register Tcl_Obj *exprPtr;
+ Tcl_Obj *resultPtr;
+ int length = strlen(string);
+ int result = TCL_OK;
+
+ if (length > 0) {
+ exprPtr = Tcl_NewStringObj(string, length);
+ Tcl_IncrRefCount(exprPtr);
+
+ result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
+ if (result == TCL_OK) {
+ /*
+ * Store a double based on the expression result.
+ */
+
+ if (resultPtr->typePtr == &tclIntType) {
+ *ptr = (double) resultPtr->internalRep.longValue;
+ } else if (resultPtr->typePtr == &tclDoubleType) {
+ *ptr = resultPtr->internalRep.doubleValue;
+ } else {
+ Tcl_SetResult(interp,
+ "expression didn't have numeric value", TCL_STATIC);
+ result = TCL_ERROR;
+ }
+ Tcl_DecrRefCount(resultPtr); /* discard the result object */
+ } else {
+ /*
+ * Move the interpreter's object result to the string result,
+ * then reset the object result.
+ * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
+ */
+
+ Tcl_SetResult(interp,
+ TclGetStringFromObj(Tcl_GetObjResult(interp),
+ (int *) NULL),
+ TCL_VOLATILE);
+ }
+ Tcl_DecrRefCount(exprPtr); /* discard the expression object */
+ } else {
+ /*
+ * An empty string. Just set the result double to 0.0.
+ */
+
+ *ptr = 0.0;
+ }
+ return result;
+}
+
+int
+Tcl_ExprBoolean(interp, string, ptr)
+ Tcl_Interp *interp; /* Context in which to evaluate the
+ * expression. */
+ char *string; /* Expression to evaluate. */
+ int *ptr; /* Where to store 0/1 result. */
+{
+ register Tcl_Obj *exprPtr;
+ Tcl_Obj *resultPtr;
+ int length = strlen(string);
+ int result = TCL_OK;
+
+ if (length > 0) {
+ exprPtr = Tcl_NewStringObj(string, length);
+ Tcl_IncrRefCount(exprPtr);
+
+ result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
+ if (result == TCL_OK) {
+ /*
+ * Store a boolean based on the expression result.
+ */
+
+ if (resultPtr->typePtr == &tclIntType) {
+ *ptr = (resultPtr->internalRep.longValue != 0);
+ } else if (resultPtr->typePtr == &tclDoubleType) {
+ *ptr = (resultPtr->internalRep.doubleValue != 0.0);
+ } else {
+ result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
+ }
+ Tcl_DecrRefCount(resultPtr); /* discard the result object */
+ }
+ if (result != TCL_OK) {
+ /*
+ * Move the interpreter's object result to the string result,
+ * then reset the object result.
+ * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
+ */
+
+ Tcl_SetResult(interp,
+ TclGetStringFromObj(Tcl_GetObjResult(interp),
+ (int *) NULL),
+ TCL_VOLATILE);
+ }
+ Tcl_DecrRefCount(exprPtr); /* discard the expression object */
+ } else {
+ /*
+ * An empty string. Just set the result boolean to 0 (false).
+ */
+
+ *ptr = 0;
+ }
+ return result;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj --
+ *
+ * Procedures to evaluate an expression in an object and return its
+ * value in a particular form.
+ *
+ * Results:
+ * Each of the procedures below returns a standard Tcl result
+ * object. If an error occurs then an error message is left in the
+ * interpreter's result. Otherwise the value of the expression, in the
+ * appropriate form, is stored at *ptr. If the expression had a result
+ * that was incompatible with the desired form then an error is
+ * returned.
+ *
+ * Side effects:
+ * None.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tcl_ExprLongObj(interp, objPtr, ptr)
+ Tcl_Interp *interp; /* Context in which to evaluate the
+ * expression. */
+ register Tcl_Obj *objPtr; /* Expression to evaluate. */
+ long *ptr; /* Where to store long result. */
+{
+ Tcl_Obj *resultPtr;
+ int result;
+
+ result = Tcl_ExprObj(interp, objPtr, &resultPtr);
+ if (result == TCL_OK) {
+ if (resultPtr->typePtr == &tclIntType) {
+ *ptr = resultPtr->internalRep.longValue;
+ } else if (resultPtr->typePtr == &tclDoubleType) {
+ *ptr = (long) resultPtr->internalRep.doubleValue;
+ } else {
+ result = Tcl_GetLongFromObj(interp, resultPtr, ptr);
+ if (result != TCL_OK) {
+ return result;
+ }
+ }
+ Tcl_DecrRefCount(resultPtr); /* discard the result object */
+ }
+ return result;
+}
+
+int
+Tcl_ExprDoubleObj(interp, objPtr, ptr)
+ Tcl_Interp *interp; /* Context in which to evaluate the
+ * expression. */
+ register Tcl_Obj *objPtr; /* Expression to evaluate. */
+ double *ptr; /* Where to store double result. */
+{
+ Tcl_Obj *resultPtr;
+ int result;
+
+ result = Tcl_ExprObj(interp, objPtr, &resultPtr);
+ if (result == TCL_OK) {
+ if (resultPtr->typePtr == &tclIntType) {
+ *ptr = (double) resultPtr->internalRep.longValue;
+ } else if (resultPtr->typePtr == &tclDoubleType) {
+ *ptr = resultPtr->internalRep.doubleValue;
+ } else {
+ result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr);
+ if (result != TCL_OK) {
+ return result;
+ }
+ }
+ Tcl_DecrRefCount(resultPtr); /* discard the result object */
+ }
+ return result;
+}
+
+int
+Tcl_ExprBooleanObj(interp, objPtr, ptr)
+ Tcl_Interp *interp; /* Context in which to evaluate the
+ * expression. */
+ register Tcl_Obj *objPtr; /* Expression to evaluate. */
+ int *ptr; /* Where to store 0/1 result. */
+{
+ Tcl_Obj *resultPtr;
+ int result;
+
+ result = Tcl_ExprObj(interp, objPtr, &resultPtr);
+ if (result == TCL_OK) {
+ if (resultPtr->typePtr == &tclIntType) {
+ *ptr = (resultPtr->internalRep.longValue != 0);
+ } else if (resultPtr->typePtr == &tclDoubleType) {
+ *ptr = (resultPtr->internalRep.doubleValue != 0.0);
+ } else {
+ result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
+ if (result != TCL_OK) {
+ return result;
+ }
+ }
+ Tcl_DecrRefCount(resultPtr); /* discard the result object */
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInvoke --
+ *
+ * Invokes a Tcl command, given an argv/argc, from either the
+ * exposed or the hidden sets of commands in the given interpreter.
+ * NOTE: The command is invoked in the current stack frame of
+ * the interpreter, thus it can modify local variables.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Whatever the command does.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclInvoke(interp, argc, argv, flags)
+ Tcl_Interp *interp; /* Where to invoke the command. */
+ int argc; /* Count of args. */
+ register char **argv; /* The arg strings; argv[0] is the name of
+ * the command to invoke. */
+ int flags; /* Combination of flags controlling the
+ * call: TCL_INVOKE_HIDDEN and
+ * TCL_INVOKE_NO_UNKNOWN. */
+{
+ register Tcl_Obj *objPtr;
+ register int i;
+ int length, result;
+
+ /*
+ * This procedure generates an objv array for object arguments that hold
+ * the argv strings. It starts out with stack-allocated space but uses
+ * dynamically-allocated storage if needed.
+ */
+
+#define NUM_ARGS 20
+ Tcl_Obj *(objStorage[NUM_ARGS]);
+ register Tcl_Obj **objv = objStorage;
+
+ /*
+ * Create the object argument array "objv". Make sure objv is large
+ * enough to hold the objc arguments plus 1 extra for the zero
+ * end-of-objv word.
+ */
+
+ if ((argc + 1) > NUM_ARGS) {
+ objv = (Tcl_Obj **)
+ ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
+ }
+
+ for (i = 0; i < argc; i++) {
+ length = strlen(argv[i]);
+ objv[i] = Tcl_NewStringObj(argv[i], length);
+ Tcl_IncrRefCount(objv[i]);
+ }
+ objv[argc] = 0;
+
+ /*
+ * Use TclObjInterpProc to actually invoke the command.
+ */
+
+ result = TclObjInvoke(interp, argc, objv, flags);
+
+ /*
+ * Move the interpreter's object result to the string result,
+ * then reset the object result.
+ * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
+ */
+
+ Tcl_SetResult(interp,
+ TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
+ TCL_VOLATILE);
+
+ /*
+ * Decrement the ref counts on the objv elements since we are done
+ * with them.
+ */
+
+ for (i = 0; i < argc; i++) {
+ objPtr = objv[i];
+ Tcl_DecrRefCount(objPtr);
+ }
+
+ /*
+ * Free the objv array if malloc'ed storage was used.
+ */
+
+ if (objv != objStorage) {
+ ckfree((char *) objv);
+ }
+ return result;
+#undef NUM_ARGS
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGlobalInvoke --
+ *
+ * Invokes a Tcl command, given an argv/argc, from either the
+ * exposed or hidden sets of commands in the given interpreter.
+ * NOTE: The command is invoked in the global stack frame of
+ * the interpreter, thus it cannot see any current state on
+ * the stack for that interpreter.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Whatever the command does.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclGlobalInvoke(interp, argc, argv, flags)
+ Tcl_Interp *interp; /* Where to invoke the command. */
+ int argc; /* Count of args. */
+ register char **argv; /* The arg strings; argv[0] is the name of
+ * the command to invoke. */
+ int flags; /* Combination of flags controlling the
+ * call: TCL_INVOKE_HIDDEN and
+ * TCL_INVOKE_NO_UNKNOWN. */
+{
+ register Interp *iPtr = (Interp *) interp;
+ int result;
+ CallFrame *savedVarFramePtr;
+
+ savedVarFramePtr = iPtr->varFramePtr;
+ iPtr->varFramePtr = NULL;
+ result = TclInvoke(interp, argc, argv, flags);
+ iPtr->varFramePtr = savedVarFramePtr;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclObjInvokeGlobal --
+ *
+ * Object version: Invokes a Tcl command, given an objv/objc, from
+ * either the exposed or hidden set of commands in the given
+ * interpreter.
+ * NOTE: The command is invoked in the global stack frame of the
+ * interpreter, thus it cannot see any current state on the
+ * stack of that interpreter.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Whatever the command does.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclObjInvokeGlobal(interp, objc, objv, flags)
+ Tcl_Interp *interp; /* Interpreter in which command is
+ * to be invoked. */
+ int objc; /* Count of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0]
+ * points to the name of the
+ * command to invoke. */
+ int flags; /* Combination of flags controlling
+ * the call: TCL_INVOKE_HIDDEN and
+ * TCL_INVOKE_NO_UNKNOWN. */
+{
+ register Interp *iPtr = (Interp *) interp;
+ int result;
+ CallFrame *savedVarFramePtr;
+
+ savedVarFramePtr = iPtr->varFramePtr;
+ iPtr->varFramePtr = NULL;
+ result = TclObjInvoke(interp, objc, objv, flags);
+ iPtr->varFramePtr = savedVarFramePtr;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclObjInvoke --
+ *
+ * Invokes a Tcl command, given an objv/objc, from either the
+ * exposed or the hidden sets of commands in the given interpreter.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * Whatever the command does.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclObjInvoke(interp, objc, objv, flags)
+ Tcl_Interp *interp; /* Interpreter in which command is
+ * to be invoked. */
+ int objc; /* Count of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0]
+ * points to the name of the
+ * command to invoke. */
+ int flags; /* Combination of flags controlling
+ * the call: TCL_INVOKE_HIDDEN and
+ * TCL_INVOKE_NO_UNKNOWN. */
+{
+ register Interp *iPtr = (Interp *) interp;
+ Tcl_HashTable *hTblPtr; /* Table of hidden commands. */
+ char *cmdName; /* Name of the command from objv[0]. */
+ register Tcl_HashEntry *hPtr;
+ Tcl_Command cmd;
+ Command *cmdPtr;
+ int localObjc; /* Used to invoke "unknown" if the */
+ Tcl_Obj **localObjv = NULL; /* command is not found. */
+ register int i;
+ int length, result;
+ char *bytes;
+
+ if (interp == (Tcl_Interp *) NULL) {
+ return TCL_ERROR;
+ }
+
+ if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "illegal argument vector", -1);
+ return TCL_ERROR;
+ }
+
+ /*
+ * THE FOLLOWING CODE FAILS IF THE STRING REP CONTAINS NULLS.
+ */
+
+ cmdName = Tcl_GetStringFromObj(objv[0], (int *) NULL);
+ if (flags & TCL_INVOKE_HIDDEN) {
+ /*
+ * Find the table of hidden commands; error out if none.
+ */
+
+ hTblPtr = (Tcl_HashTable *)
+ Tcl_GetAssocData(interp, "tclHiddenCmds", NULL);
+ if (hTblPtr == (Tcl_HashTable *) NULL) {
+ badHiddenCmdName:
+ Tcl_ResetResult(interp);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "invalid hidden command name \"", cmdName, "\"",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
+
+ /*
+ * We never invoke "unknown" for hidden commands.
+ */
+
+ if (hPtr == NULL) {
+ goto badHiddenCmdName;
+ }
+ cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
} else {
+ cmdPtr = NULL;
+ cmd = Tcl_FindCommand(interp, cmdName,
+ (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
+ if (cmd != (Tcl_Command) NULL) {
+ cmdPtr = (Command *) cmd;
+ }
+ if (cmdPtr == NULL) {
+ if (!(flags & TCL_INVOKE_NO_UNKNOWN)) {
+ cmd = Tcl_FindCommand(interp, "unknown",
+ (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
+ if (cmd != (Tcl_Command) NULL) {
+ cmdPtr = (Command *) cmd;
+ }
+ if (cmdPtr != NULL) {
+ localObjc = (objc + 1);
+ localObjv = (Tcl_Obj **)
+ ckalloc((unsigned) (sizeof(Tcl_Obj *) * localObjc));
+ localObjv[0] = Tcl_NewStringObj("unknown", -1);
+ Tcl_IncrRefCount(localObjv[0]);
+ for (i = 0; i < objc; i++) {
+ localObjv[i+1] = objv[i];
+ }
+ objc = localObjc;
+ objv = localObjv;
+ }
+ }
+
+ /*
+ * Check again if we found the command. If not, "unknown" is
+ * not present and we cannot help, or the caller said not to
+ * call "unknown" (they specified TCL_INVOKE_NO_UNKNOWN).
+ */
+
+ if (cmdPtr == NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "invalid command name \"", cmdName, "\"",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ }
+ }
+
+ /*
+ * Invoke the command procedure. First reset the interpreter's string
+ * and object results to their default empty values since they could
+ * have gotten changed by earlier invocations.
+ */
+
+ Tcl_ResetResult(interp);
+ iPtr->cmdCount++;
+ result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
+
+ /*
+ * If an error occurred, record information about what was being
+ * executed when the error occurred.
+ */
+
+ if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
+ Tcl_DString ds;
+
+ Tcl_DStringInit(&ds);
+ if (!(iPtr->flags & ERR_IN_PROGRESS)) {
+ Tcl_DStringAppend(&ds, "\n while invoking\n\"", -1);
+ } else {
+ Tcl_DStringAppend(&ds, "\n invoked from within\n\"", -1);
+ }
+ for (i = 0; i < objc; i++) {
+ bytes = Tcl_GetStringFromObj(objv[i], &length);
+ Tcl_DStringAppend(&ds, bytes, length);
+ if (i < (objc - 1)) {
+ Tcl_DStringAppend(&ds, " ", -1);
+ } else if (Tcl_DStringLength(&ds) > 100) {
+ Tcl_DStringSetLength(&ds, 100);
+ Tcl_DStringAppend(&ds, "...", -1);
+ break;
+ }
+ }
+
+ Tcl_DStringAppend(&ds, "\"", -1);
+ Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&ds), -1);
+ Tcl_DStringFree(&ds);
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
- iPtr->termPtr = termPtr;
+
+ /*
+ * Free any locally allocated storage used to call "unknown".
+ */
+
+ if (localObjv != (Tcl_Obj **) NULL) {
+ ckfree((char *) localObjv);
+ }
+ return result;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tcl_ExprString --
+ *
+ * Evaluate an expression in a string and return its value in string
+ * form.
+ *
+ * Results:
+ * A standard Tcl result. If the result is TCL_OK, then the
+ * interpreter's result is set to the string value of the
+ * expression. If the result is TCL_OK, then interp->result
+ * contains an error message.
+ *
+ * Side effects:
+ * A Tcl object is allocated to hold a copy of the expression string.
+ * This expression object is passed to Tcl_ExprObj and then
+ * deallocated.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tcl_ExprString(interp, string)
+ Tcl_Interp *interp; /* Context in which to evaluate the
+ * expression. */
+ char *string; /* Expression to evaluate. */
+{
+ register Tcl_Obj *exprPtr;
+ Tcl_Obj *resultPtr;
+ int length = strlen(string);
+ char buf[100];
+ int result = TCL_OK;
+
+ if (length > 0) {
+ TclNewObj(exprPtr);
+ TclInitStringRep(exprPtr, string, length);
+ Tcl_DecrRefCount(exprPtr);
+
+ result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
+ if (result == TCL_OK) {
+ /*
+ * Set the interpreter's string result from the result object.
+ */
+
+ if (resultPtr->typePtr == &tclIntType) {
+ sprintf(buf, "%ld", resultPtr->internalRep.longValue);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ } else if (resultPtr->typePtr == &tclDoubleType) {
+ Tcl_PrintDouble((Tcl_Interp *) NULL,
+ resultPtr->internalRep.doubleValue, buf);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ } else {
+ /*
+ * Set interpreter's string result from the result object.
+ * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
+ */
+
+ Tcl_SetResult(interp,
+ TclGetStringFromObj(resultPtr, (int *) NULL),
+ TCL_VOLATILE);
+ }
+ Tcl_DecrRefCount(resultPtr); /* discard the result object */
+ } else {
+ /*
+ * Move the interpreter's object result to the string result,
+ * then reset the object result.
+ * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
+ */
+
+ Tcl_SetResult(interp,
+ TclGetStringFromObj(Tcl_GetObjResult(interp),
+ (int *) NULL),
+ TCL_VOLATILE);
+ }
+ Tcl_DecrRefCount(exprPtr); /* discard the expression object */
+ } else {
+ /*
+ * An empty string. Just set the interpreter's result to 0.
+ */
+
+ Tcl_SetResult(interp, "0", TCL_VOLATILE);
+ }
+ return result;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tcl_ExprObj --
+ *
+ * Evaluate an expression in a Tcl_Obj.
+ *
+ * Results:
+ * A standard Tcl object result. If the result is other than TCL_OK,
+ * then the interpreter's result contains an error message. If the
+ * result is TCL_OK, then a pointer to the expression's result value
+ * object is stored in resultPtrPtr. In that case, the object's ref
+ * count is incremented to reflect the reference returned to the
+ * caller; the caller is then responsible for the resulting object
+ * and must, for example, decrement the ref count when it is finished
+ * with the object.
+ *
+ * Side effects:
+ * Any side effects caused by subcommands in the expression, if any.
+ * The interpreter result is not modified unless there is an error.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tcl_ExprObj(interp, objPtr, resultPtrPtr)
+ Tcl_Interp *interp; /* Context in which to evaluate the
+ * expression. */
+ register Tcl_Obj *objPtr; /* Points to Tcl object containing
+ * expression to evaluate. */
+ Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression
+ * result is stored if no errors occur. */
+{
+ Interp *iPtr = (Interp *) interp;
+ CompileEnv compEnv; /* Compilation environment structure
+ * allocated in frame. */
+ register ByteCode *codePtr = NULL;
+ /* Tcl Internal type of bytecode.
+ * Initialized to avoid compiler warning. */
+ AuxData *auxDataPtr;
+ Interp dummy;
+ Tcl_Obj *saveObjPtr;
+ char *string;
+ int result = TCL_OK;
+ int i;
+
+ /*
+ * Get the ByteCode from the object. If it exists, make sure it hasn't
+ * been invalidated by, e.g., someone redefining a command with a
+ * compile procedure (this might make the compiled code wrong). If
+ * necessary, convert the object to be a ByteCode object and compile it.
+ * Also, if the code was compiled in/for a different interpreter, we
+ * recompile it.
+ * THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE.
+ */
+
+ if (objPtr->typePtr == &tclByteCodeType) {
+ codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ if ((codePtr->iPtr != iPtr)
+ || (codePtr->compileEpoch != iPtr->compileEpoch)) {
+ tclByteCodeType.freeIntRepProc(objPtr);
+ objPtr->typePtr = (Tcl_ObjType *) NULL;
+ }
+ }
+ if (objPtr->typePtr != &tclByteCodeType) {
+ int length;
+ string = Tcl_GetStringFromObj(objPtr, &length);
+ TclInitCompileEnv(interp, &compEnv, string);
+ result = TclCompileExpr(interp, string, string + length,
+ /*flags*/ 0, &compEnv);
+ if (result == TCL_OK) {
+ /*
+ * If the expression yielded no instructions (e.g., was empty),
+ * push an integer zero object as the expressions's result.
+ */
+
+ if (compEnv.codeNext == NULL) {
+ int objIndex = TclObjIndexForString("0", 0,
+ /*allocStrRep*/ 0, /*inHeap*/ 0, &compEnv);
+ Tcl_Obj *objPtr = compEnv.objArrayPtr[objIndex];
+
+ Tcl_InvalidateStringRep(objPtr);
+ objPtr->internalRep.longValue = 0;
+ objPtr->typePtr = &tclIntType;
+
+ TclEmitPush(objIndex, &compEnv);
+ }
+
+ /*
+ * Add done instruction at the end of the instruction sequence.
+ */
+
+ TclEmitOpcode(INST_DONE, &compEnv);
+
+ TclInitByteCodeObj(objPtr, &compEnv);
+ codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ if (tclTraceCompile == 2) {
+ TclPrintByteCodeObj(interp, objPtr);
+ }
+ TclFreeCompileEnv(&compEnv);
+ } else {
+ /*
+ * Compilation errors. Decrement the ref counts on any objects
+ * in the object array before freeing the compilation
+ * environment.
+ */
+
+ for (i = 0; i < compEnv.objArrayNext; i++) {
+ Tcl_Obj *elemPtr = compEnv.objArrayPtr[i];
+ Tcl_DecrRefCount(elemPtr);
+ }
+
+ auxDataPtr = compEnv.auxDataArrayPtr;
+ for (i = 0; i < compEnv.auxDataArrayNext; i++) {
+ if (auxDataPtr->freeProc != NULL) {
+ auxDataPtr->freeProc(auxDataPtr->clientData);
+ }
+ auxDataPtr++;
+ }
+ TclFreeCompileEnv(&compEnv);
+ return result;
+ }
+ }
+
+ /*
+ * Execute the expression after first saving the interpreter's result.
+ */
+
+ dummy.objResultPtr = Tcl_NewObj();
+ Tcl_IncrRefCount(dummy.objResultPtr);
+ if (interp->freeProc == 0) {
+ dummy.freeProc = (Tcl_FreeProc *) 0;
+ dummy.result = "";
+ Tcl_SetResult((Tcl_Interp *) &dummy, interp->result,
+ TCL_VOLATILE);
+ } else {
+ dummy.freeProc = interp->freeProc;
+ dummy.result = interp->result;
+ interp->freeProc = (Tcl_FreeProc *) 0;
+ }
+
+ saveObjPtr = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(saveObjPtr);
+
+ /*
+ * Increment the code's ref count while it is being executed. If
+ * afterwards no references to it remain, free the code.
+ */
+
+ codePtr->refCount++;
+ result = TclExecuteByteCode(interp, codePtr);
+ codePtr->refCount--;
+ if (codePtr->refCount <= 0) {
+ TclCleanupByteCode(codePtr);
+ }
+
+ /*
+ * If the expression evaluated successfully, store a pointer to its
+ * value object in resultPtrPtr then restore the old interpreter result.
+ * We increment the object's ref count to reflect the reference that we
+ * are returning to the caller. We also decrement the ref count of the
+ * interpreter's result object after calling Tcl_SetResult since we
+ * next store into that field directly.
+ */
+
+ if (result == TCL_OK) {
+ *resultPtrPtr = iPtr->objResultPtr;
+ Tcl_IncrRefCount(iPtr->objResultPtr);
+
+ Tcl_SetResult(interp, dummy.result,
+ ((dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc));
+ Tcl_DecrRefCount(iPtr->objResultPtr);
+ iPtr->objResultPtr = saveObjPtr;
+ } else {
+ Tcl_DecrRefCount(saveObjPtr);
+ Tcl_FreeResult((Tcl_Interp *) &dummy);
+ }
+
+ Tcl_DecrRefCount(dummy.objResultPtr);
+ dummy.objResultPtr = NULL;
return result;
}
@@ -1587,16 +3739,27 @@ Tcl_Eval(interp, cmd)
Tcl_Trace
Tcl_CreateTrace(interp, level, proc, clientData)
- Tcl_Interp *interp; /* Interpreter in which to create the trace. */
- int level; /* Only call proc for commands at nesting level
- * <= level (1 => top level). */
+ Tcl_Interp *interp; /* Interpreter in which to create trace. */
+ int level; /* Only call proc for commands at nesting
+ * level<=argument level (1=>top level). */
Tcl_CmdTraceProc *proc; /* Procedure to call before executing each
* command. */
- ClientData clientData; /* Arbitrary one-word value to pass to proc. */
+ ClientData clientData; /* Arbitrary value word to pass to proc. */
{
register Trace *tracePtr;
register Interp *iPtr = (Interp *) interp;
+ /*
+ * Invalidate existing compiled code for this interpreter and arrange
+ * (by setting the DONT_COMPILE_CMDS_INLINE flag) that when compiling
+ * new code, no commands will be compiled inline (i.e., into an inline
+ * sequence of instructions). We do this because commands that were
+ * compiled inline will never result in a command trace being called.
+ */
+
+ iPtr->compileEpoch++;
+ iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
+
tracePtr = (Trace *) ckalloc(sizeof(Trace));
tracePtr->level = level;
tracePtr->proc = proc;
@@ -1643,10 +3806,18 @@ Tcl_DeleteTrace(interp, trace)
if (tracePtr2->nextPtr == tracePtr) {
tracePtr2->nextPtr = tracePtr->nextPtr;
ckfree((char *) tracePtr);
- return;
+ break;
}
}
}
+
+ if (iPtr->tracePtr == NULL) {
+ /*
+ * When compiling new code, allow commands to be compiled inline.
+ */
+
+ iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE;
+ }
}
/*
@@ -1654,8 +3825,8 @@ Tcl_DeleteTrace(interp, trace)
*
* Tcl_AddErrorInfo --
*
- * Add information to a message being accumulated that describes
- * the current error.
+ * Add information to the "errorInfo" variable that describes the
+ * current error.
*
* Results:
* None.
@@ -1664,6 +3835,8 @@ Tcl_DeleteTrace(interp, trace)
* The contents of message are added to the "errorInfo" variable.
* If Tcl_Eval has been called since the current value of errorInfo
* was set, errorInfo is cleared before adding the new message.
+ * If we are just starting to log an error, errorInfo is initialized
+ * from the error message in the interpreter's result.
*
*----------------------------------------------------------------------
*/
@@ -1674,21 +3847,64 @@ Tcl_AddErrorInfo(interp, message)
* pertains. */
char *message; /* Message to record. */
{
- register Interp *iPtr = (Interp *) interp;
+ Tcl_AddObjErrorInfo(interp, message, -1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AddObjErrorInfo --
+ *
+ * Add information to the "errorInfo" variable that describes the
+ * current error. This routine differs from Tcl_AddErrorInfo by
+ * taking a byte pointer and length.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * "length" bytes from "message" are added to the "errorInfo" variable.
+ * If "length" is negative, use bytes up to the first NULL byte.
+ * If Tcl_EvalObj has been called since the current value of errorInfo
+ * was set, errorInfo is cleared before adding the new message.
+ * If we are just starting to log an error, errorInfo is initialized
+ * from the error message in the interpreter's result.
+ *
+ *----------------------------------------------------------------------
+ */
+void
+Tcl_AddObjErrorInfo(interp, message, length)
+ Tcl_Interp *interp; /* Interpreter to which error information
+ * pertains. */
+ char *message; /* Points to the first byte of an array of
+ * bytes of the message. */
+ register int length; /* The number of bytes in the message.
+ * If < 0, then append all bytes up to a
+ * NULL byte. */
+{
+ register Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *namePtr, *messagePtr;
+
/*
- * If an error is already being logged, then the new errorInfo
- * is the concatenation of the old info and the new message.
- * If this is the first piece of info for the error, then the
- * new errorInfo is the concatenation of the message in
- * interp->result and the new message.
+ * If we are just starting to log an error, errorInfo is initialized
+ * from the error message in the interpreter's result.
*/
- if (!(iPtr->flags & ERR_IN_PROGRESS)) {
- Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
- TCL_GLOBAL_ONLY);
+ namePtr = Tcl_NewStringObj("errorInfo", -1);
+ Tcl_IncrRefCount(namePtr);
+
+ if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */
iPtr->flags |= ERR_IN_PROGRESS;
+ if (iPtr->result[0] == 0) {
+ (void) Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL,
+ iPtr->objResultPtr, TCL_GLOBAL_ONLY);
+ } else { /* use the string result */
+ Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
+ TCL_GLOBAL_ONLY);
+ }
+
/*
* If the errorCode variable wasn't set by the code that generated
* the error, set it to "NONE".
@@ -1699,8 +3915,18 @@ Tcl_AddErrorInfo(interp, message)
TCL_GLOBAL_ONLY);
}
}
- Tcl_SetVar2(interp, "errorInfo", (char *) NULL, message,
- TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
+
+ /*
+ * Now append "message" to the end of errorInfo.
+ */
+
+ messagePtr = Tcl_NewStringObj(message, length);
+ Tcl_IncrRefCount(messagePtr);
+ Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, messagePtr,
+ (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
+ Tcl_DecrRefCount(messagePtr); /* free msg object appended above */
+
+ Tcl_DecrRefCount(namePtr); /* free the name object */
}
/*
@@ -1792,6 +4018,51 @@ Tcl_GlobalEval(interp, command)
/*
*----------------------------------------------------------------------
*
+ * Tcl_GlobalEvalObj --
+ *
+ * Execute Tcl commands stored in a Tcl object at global level in
+ * an interpreter. These commands are compiled into bytecodes if
+ * necessary.
+ *
+ * Results:
+ * A standard Tcl result is returned, and the interpreter's result
+ * contains a Tcl object value to supplement the return code.
+ *
+ * Side effects:
+ * The object is converted, if necessary, to a ByteCode object that
+ * holds the bytecode instructions for the commands. Executing the
+ * commands will almost certainly have side effects that depend on
+ * those commands.
+ *
+ * The commands are executed in interp, and the execution
+ * is carried out in the variable context of global level (no
+ * procedures active), just as if an "uplevel #0" command were
+ * being executed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GlobalEvalObj(interp, objPtr)
+ Tcl_Interp *interp; /* Interpreter in which to evaluate
+ * commands. */
+ Tcl_Obj *objPtr; /* Pointer to object containing commands
+ * to execute. */
+{
+ register Interp *iPtr = (Interp *) interp;
+ int result;
+ CallFrame *savedVarFramePtr;
+
+ savedVarFramePtr = iPtr->varFramePtr;
+ iPtr->varFramePtr = NULL;
+ result = Tcl_EvalObj(interp, objPtr);
+ iPtr->varFramePtr = savedVarFramePtr;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_SetRecursionLimit --
*
* Set the maximum number of recursive calls that may be active
@@ -1850,3 +4121,4 @@ Tcl_AllowExceptions(interp)
iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS;
}
+
diff --git a/contrib/tcl/generic/tclBinary.c b/contrib/tcl/generic/tclBinary.c
new file mode 100644
index 000000000000..28190cc355ed
--- /dev/null
+++ b/contrib/tcl/generic/tclBinary.c
@@ -0,0 +1,977 @@
+/*
+ * tclBinary.c --
+ *
+ * This file contains the implementation of the "binary" Tcl built-in
+ * command .
+ *
+ * Copyright (c) 1997 by Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclBinary.c 1.16 97/05/19 10:29:18
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+
+/*
+ * The following constants are used by GetFormatSpec to indicate various
+ * special conditions in the parsing of a format specifier.
+ */
+
+#define BINARY_ALL -1 /* Use all elements in the argument. */
+#define BINARY_NOCOUNT -2 /* No count was specified in format. */
+
+/*
+ * Prototypes for local procedures defined in this file:
+ */
+
+static int GetFormatSpec _ANSI_ARGS_((char **formatPtr,
+ char *cmdPtr, int *countPtr));
+static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type,
+ Tcl_Obj *src, char **cursorPtr));
+static Tcl_Obj * ScanNumber _ANSI_ARGS_((char *buffer, int type));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_BinaryObjCmd --
+ *
+ * This procedure implements the "binary" Tcl command.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_BinaryObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ int arg; /* Index of next argument to consume. */
+ int value = 0; /* Current integer value to be packed.
+ * Initialized to avoid compiler warning. */
+ char cmd; /* Current format character. */
+ int count; /* Count associated with current format
+ * character. */
+ char *format; /* Pointer to current position in format
+ * string. */
+ char *cursor; /* Current position within result buffer. */
+ char *maxPos; /* Greatest position within result buffer that
+ * cursor has visited.*/
+ char *buffer; /* Start of data buffer. */
+ char *errorString, *errorValue, *str;
+ int offset, size, length;
+ Tcl_Obj *resultPtr;
+
+ static char *subCmds[] = { "format", "scan", (char *) NULL };
+ enum { BinaryFormat, BinaryScan } index;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
+ (int *) &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch (index) {
+ case BinaryFormat:
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?");
+ return TCL_ERROR;
+ }
+ /*
+ * To avoid copying the data, we format the string in two passes.
+ * The first pass computes the size of the output buffer. The
+ * second pass places the formatted data into the buffer.
+ */
+
+ format = Tcl_GetStringFromObj(objv[2], NULL);
+ arg = 3;
+ offset = length = 0;
+ while (*format != 0) {
+ if (!GetFormatSpec(&format, &cmd, &count)) {
+ break;
+ }
+ switch (cmd) {
+ case 'a':
+ case 'A':
+ case 'b':
+ case 'B':
+ case 'h':
+ case 'H':
+ /*
+ * For string-type specifiers, the count corresponds
+ * to the number of characters in a single argument.
+ */
+
+ if (arg >= objc) {
+ goto badIndex;
+ }
+ if (count == BINARY_ALL) {
+ (void)Tcl_GetStringFromObj(objv[arg], &count);
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ arg++;
+ if (cmd == 'a' || cmd == 'A') {
+ offset += count;
+ } else if (cmd == 'b' || cmd == 'B') {
+ offset += (count + 7) / 8;
+ } else {
+ offset += (count + 1) / 2;
+ }
+ break;
+
+ case 'c':
+ size = 1;
+ goto doNumbers;
+ case 's':
+ case 'S':
+ size = 2;
+ goto doNumbers;
+ case 'i':
+ case 'I':
+ size = 4;
+ goto doNumbers;
+ case 'f':
+ size = sizeof(float);
+ goto doNumbers;
+ case 'd':
+ size = sizeof(double);
+ doNumbers:
+ if (arg >= objc) {
+ goto badIndex;
+ }
+
+ /*
+ * For number-type specifiers, the count corresponds
+ * to the number of elements in the list stored in
+ * a single argument. If no count is specified, then
+ * the argument is taken as a single non-list value.
+ */
+
+ if (count == BINARY_NOCOUNT) {
+ arg++;
+ count = 1;
+ } else {
+ int listc;
+ Tcl_Obj **listv;
+ if (Tcl_ListObjGetElements(interp, objv[arg++],
+ &listc, &listv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (count == BINARY_ALL) {
+ count = listc;
+ } else if (count > listc) {
+ errorString = "number of elements in list does not match count";
+ goto error;
+ }
+ }
+ offset += count*size;
+ break;
+
+ case 'x':
+ if (count == BINARY_ALL) {
+ errorString = "cannot use \"*\" in format string with \"x\"";
+ goto error;
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ offset += count;
+ break;
+ case 'X':
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if ((count > offset) || (count == BINARY_ALL)) {
+ count = offset;
+ }
+ if (offset > length) {
+ length = offset;
+ }
+ offset -= count;
+ break;
+ case '@':
+ if (offset > length) {
+ length = offset;
+ }
+ if (count == BINARY_ALL) {
+ offset = length;
+ } else if (count == BINARY_NOCOUNT) {
+ goto badCount;
+ } else {
+ offset = count;
+ }
+ break;
+ default: {
+ char buf[2];
+
+ Tcl_ResetResult(interp);
+ buf[0] = cmd;
+ buf[1] = '\0';
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "bad field specifier \"", buf, "\"", NULL);
+ return TCL_ERROR;
+ }
+ }
+ }
+ if (offset > length) {
+ length = offset;
+ }
+ if (length == 0) {
+ return TCL_OK;
+ }
+
+ /*
+ * Prepare the result object by preallocating the caclulated
+ * number of bytes and filling with nulls.
+ */
+
+ resultPtr = Tcl_GetObjResult(interp);
+ Tcl_SetObjLength(resultPtr, length);
+ buffer = Tcl_GetStringFromObj(resultPtr, NULL);
+ memset(buffer, 0, (size_t) length);
+
+ /*
+ * Pack the data into the result object. Note that we can skip
+ * the error checking during this pass, since we have already
+ * parsed the string once.
+ */
+
+ arg = 3;
+ format = Tcl_GetStringFromObj(objv[2], NULL);
+ cursor = buffer;
+ maxPos = cursor;
+ while (*format != 0) {
+ if (!GetFormatSpec(&format, &cmd, &count)) {
+ break;
+ }
+ if ((count == 0) && (cmd != '@')) {
+ arg++;
+ continue;
+ }
+ switch (cmd) {
+ case 'a':
+ case 'A': {
+ char pad = (char) (cmd == 'a' ? '\0' : ' ');
+
+ str = Tcl_GetStringFromObj(objv[arg++], &length);
+
+ if (count == BINARY_ALL) {
+ count = length;
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if (length >= count) {
+ memcpy(cursor, str, (size_t) count);
+ } else {
+ memcpy(cursor, str, (size_t) length);
+ memset(cursor+length, pad,
+ (size_t) (count - length));
+ }
+ cursor += count;
+ break;
+ }
+ case 'b':
+ case 'B': {
+ char *last;
+
+ str = Tcl_GetStringFromObj(objv[arg++], &length);
+ if (count == BINARY_ALL) {
+ count = length;
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ last = cursor + ((count + 7) / 8);
+ if (count > length) {
+ count = length;
+ }
+ value = 0;
+ errorString = "binary";
+ if (cmd == 'B') {
+ for (offset = 0; offset < count; offset++) {
+ value <<= 1;
+ if (str[offset] == '1') {
+ value |= 1;
+ } else if (str[offset] != '0') {
+ errorValue = str;
+ goto badValue;
+ }
+ if (((offset + 1) % 8) == 0) {
+ *cursor++ = (char)(value & 0xff);
+ value = 0;
+ }
+ }
+ } else {
+ for (offset = 0; offset < count; offset++) {
+ value >>= 1;
+ if (str[offset] == '1') {
+ value |= 128;
+ } else if (str[offset] != '0') {
+ errorValue = str;
+ goto badValue;
+ }
+ if (!((offset + 1) % 8)) {
+ *cursor++ = (char)(value & 0xff);
+ value = 0;
+ }
+ }
+ }
+ if ((offset % 8) != 0) {
+ if (cmd == 'B') {
+ value <<= 8 - (offset % 8);
+ } else {
+ value >>= 8 - (offset % 8);
+ }
+ *cursor++ = (char)(value & 0xff);
+ }
+ while (cursor < last) {
+ *cursor++ = '\0';
+ }
+ break;
+ }
+ case 'h':
+ case 'H': {
+ char *last;
+ int c;
+
+ str = Tcl_GetStringFromObj(objv[arg++], &length);
+ if (count == BINARY_ALL) {
+ count = length;
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ last = cursor + ((count + 1) / 2);
+ if (count > length) {
+ count = length;
+ }
+ value = 0;
+ errorString = "hexadecimal";
+ if (cmd == 'H') {
+ for (offset = 0; offset < count; offset++) {
+ value <<= 4;
+ c = tolower(((unsigned char *) str)[offset]);
+ if ((c >= 'a') && (c <= 'f')) {
+ value |= ((c - 'a' + 10) & 0xf);
+ } else if ((c >= '0') && (c <= '9')) {
+ value |= (c - '0') & 0xf;
+ } else {
+ errorValue = str;
+ goto badValue;
+ }
+ if (offset % 2) {
+ *cursor++ = (char) value;
+ value = 0;
+ }
+ }
+ } else {
+ for (offset = 0; offset < count; offset++) {
+ value >>= 4;
+ c = tolower(((unsigned char *) str)[offset]);
+ if ((c >= 'a') && (c <= 'f')) {
+ value |= ((c - 'a' + 10) << 4) & 0xf0;
+ } else if ((c >= '0') && (c <= '9')) {
+ value |= ((c - '0') << 4) & 0xf0;
+ } else {
+ errorValue = str;
+ goto badValue;
+ }
+ if (offset % 2) {
+ *cursor++ = (char)(value & 0xff);
+ value = 0;
+ }
+ }
+ }
+ if (offset % 2) {
+ if (cmd == 'H') {
+ value <<= 4;
+ } else {
+ value >>= 4;
+ }
+ *cursor++ = (char) value;
+ }
+
+ while (cursor < last) {
+ *cursor++ = '\0';
+ }
+ break;
+ }
+ case 'c':
+ case 's':
+ case 'S':
+ case 'i':
+ case 'I':
+ case 'd':
+ case 'f': {
+ int listc, i;
+ Tcl_Obj **listv;
+
+ if (count == BINARY_NOCOUNT) {
+ /*
+ * Note that we are casting away the const-ness of
+ * objv, but this is safe since we aren't going to
+ * modify the array.
+ */
+
+ listv = (Tcl_Obj**)(objv + arg);
+ listc = 1;
+ count = 1;
+ } else {
+ Tcl_ListObjGetElements(interp, objv[arg],
+ &listc, &listv);
+ if (count == BINARY_ALL) {
+ count = listc;
+ }
+ }
+ arg++;
+ for (i = 0; i < count; i++) {
+ if (FormatNumber(interp, cmd, listv[i], &cursor)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ break;
+ }
+ case 'x':
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ memset(cursor, 0, (size_t) count);
+ cursor += count;
+ break;
+ case 'X':
+ if (cursor > maxPos) {
+ maxPos = cursor;
+ }
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if ((count == BINARY_ALL)
+ || (count > (cursor - buffer))) {
+ cursor = buffer;
+ } else {
+ cursor -= count;
+ }
+ break;
+ case '@':
+ if (cursor > maxPos) {
+ maxPos = cursor;
+ }
+ if (count == BINARY_ALL) {
+ cursor = maxPos;
+ } else {
+ cursor = buffer + count;
+ }
+ break;
+ }
+ }
+ break;
+
+ case BinaryScan: {
+ int i;
+ Tcl_Obj *valuePtr, *elementPtr;
+
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "value formatString ?varName varName ...?");
+ return TCL_ERROR;
+ }
+ buffer = Tcl_GetStringFromObj(objv[2], &length);
+ format = Tcl_GetStringFromObj(objv[3], NULL);
+ cursor = buffer;
+ arg = 4;
+ offset = 0;
+ while (*format != 0) {
+ if (!GetFormatSpec(&format, &cmd, &count)) {
+ goto done;
+ }
+ switch (cmd) {
+ case 'a':
+ case 'A':
+ if (arg >= objc) {
+ goto badIndex;
+ }
+ if (count == BINARY_ALL) {
+ count = length - offset;
+ } else {
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if (count > (length - offset)) {
+ goto done;
+ }
+ }
+
+ str = buffer + offset;
+ size = count;
+
+ /*
+ * Trim trailing nulls and spaces, if necessary.
+ */
+
+ if (cmd == 'A') {
+ while (size > 0) {
+ if (str[size-1] != '\0' && str[size-1] != ' ') {
+ break;
+ }
+ size--;
+ }
+ }
+ valuePtr = Tcl_NewStringObj(str, size);
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
+ valuePtr,
+ TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
+ if (resultPtr == NULL) {
+ Tcl_DecrRefCount(valuePtr); /* unneeded */
+ return TCL_ERROR;
+ }
+ offset += count;
+ break;
+ case 'b':
+ case 'B': {
+ char *dest;
+
+ if (arg >= objc) {
+ goto badIndex;
+ }
+ if (count == BINARY_ALL) {
+ count = (length - offset)*8;
+ } else {
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if (count > (length - offset)*8) {
+ goto done;
+ }
+ }
+ str = buffer + offset;
+ valuePtr = Tcl_NewObj();
+ Tcl_SetObjLength(valuePtr, count);
+ dest = Tcl_GetStringFromObj(valuePtr, NULL);
+
+ if (cmd == 'b') {
+ for (i = 0; i < count; i++) {
+ if (i % 8) {
+ value >>= 1;
+ } else {
+ value = *str++;
+ }
+ *dest++ = (char) ((value & 1) ? '1' : '0');
+ }
+ } else {
+ for (i = 0; i < count; i++) {
+ if (i % 8) {
+ value <<= 1;
+ } else {
+ value = *str++;
+ }
+ *dest++ = (char) ((value & 0x80) ? '1' : '0');
+ }
+ }
+
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
+ valuePtr,
+ TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
+ if (resultPtr == NULL) {
+ Tcl_DecrRefCount(valuePtr); /* unneeded */
+ return TCL_ERROR;
+ }
+ offset += (count + 7 ) / 8;
+ break;
+ }
+ case 'h':
+ case 'H': {
+ char *dest;
+ int i;
+ static char hexdigit[] = "0123456789abcdef";
+
+ if (arg >= objc) {
+ goto badIndex;
+ }
+ if (count == BINARY_ALL) {
+ count = (length - offset)*2;
+ } else {
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if (count > (length - offset)*2) {
+ goto done;
+ }
+ }
+ str = buffer + offset;
+ valuePtr = Tcl_NewObj();
+ Tcl_SetObjLength(valuePtr, count);
+ dest = Tcl_GetStringFromObj(valuePtr, NULL);
+
+ if (cmd == 'h') {
+ for (i = 0; i < count; i++) {
+ if (i % 2) {
+ value >>= 4;
+ } else {
+ value = *str++;
+ }
+ *dest++ = hexdigit[value & 0xf];
+ }
+ } else {
+ for (i = 0; i < count; i++) {
+ if (i % 2) {
+ value <<= 4;
+ } else {
+ value = *str++;
+ }
+ *dest++ = hexdigit[(value >> 4) & 0xf];
+ }
+ }
+
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
+ valuePtr,
+ TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
+ if (resultPtr == NULL) {
+ Tcl_DecrRefCount(valuePtr); /* unneeded */
+ return TCL_ERROR;
+ }
+ offset += (count + 1) / 2;
+ break;
+ }
+ case 'c':
+ size = 1;
+ goto scanNumber;
+ case 's':
+ case 'S':
+ size = 2;
+ goto scanNumber;
+ case 'i':
+ case 'I':
+ size = 4;
+ goto scanNumber;
+ case 'f':
+ size = sizeof(float);
+ goto scanNumber;
+ case 'd':
+ size = sizeof(double);
+ /* fall through */
+ scanNumber:
+ if (arg >= objc) {
+ goto badIndex;
+ }
+ if (count == BINARY_NOCOUNT) {
+ if ((length - offset) < size) {
+ goto done;
+ }
+ valuePtr = ScanNumber(buffer+offset, cmd);
+ offset += size;
+ } else {
+ if (count == BINARY_ALL) {
+ count = (length - offset) / size;
+ }
+ if ((length - offset) < (count * size)) {
+ goto done;
+ }
+ valuePtr = Tcl_NewObj();
+ str = buffer+offset;
+ for (i = 0; i < count; i++) {
+ elementPtr = ScanNumber(str, cmd);
+ str += size;
+ Tcl_ListObjAppendElement(NULL, valuePtr,
+ elementPtr);
+ }
+ offset += count*size;
+ }
+
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
+ valuePtr,
+ TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
+ if (resultPtr == NULL) {
+ Tcl_DecrRefCount(valuePtr); /* unneeded */
+ return TCL_ERROR;
+ }
+ break;
+ case 'x':
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if ((count == BINARY_ALL)
+ || (count > (length - offset))) {
+ offset = length;
+ } else {
+ offset += count;
+ }
+ break;
+ case 'X':
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if ((count == BINARY_ALL) || (count > offset)) {
+ offset = 0;
+ } else {
+ offset -= count;
+ }
+ break;
+ case '@':
+ if (count == BINARY_NOCOUNT) {
+ goto badCount;
+ }
+ if ((count == BINARY_ALL) || (count > length)) {
+ offset = length;
+ } else {
+ offset = count;
+ }
+ break;
+ default: {
+ char buf[2];
+
+ Tcl_ResetResult(interp);
+ buf[0] = cmd;
+ buf[1] = '\0';
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "bad field specifier \"", buf, "\"", NULL);
+ return TCL_ERROR;
+ }
+ }
+ }
+
+ /*
+ * Set the result to the last position of the cursor.
+ */
+
+ done:
+ Tcl_ResetResult(interp);
+ Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4);
+ break;
+ }
+ }
+ return TCL_OK;
+
+ badValue:
+ Tcl_ResetResult(interp);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "expected ", errorString,
+ " string but got \"", errorValue, "\" instead", NULL);
+ return TCL_ERROR;
+
+ badCount:
+ errorString = "missing count for \"@\" field specifier";
+ goto error;
+
+ badIndex:
+ errorString = "not enough arguments for all format specifiers";
+ goto error;
+
+ error:
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), errorString, -1);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetFormatSpec --
+ *
+ * This function parses the format strings used in the binary
+ * format and scan commands.
+ *
+ * Results:
+ * Moves the formatPtr to the start of the next command. Returns
+ * the current command character and count in cmdPtr and countPtr.
+ * The count is set to BINARY_ALL if the count character was '*'
+ * or BINARY_NOCOUNT if no count was specified. Returns 1 on
+ * success, or 0 if the string did not have a format specifier.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetFormatSpec(formatPtr, cmdPtr, countPtr)
+ char **formatPtr; /* Pointer to format string. */
+ char *cmdPtr; /* Pointer to location of command char. */
+ int *countPtr; /* Pointer to repeat count value. */
+{
+ /*
+ * Skip any leading blanks.
+ */
+
+ while (**formatPtr == ' ') {
+ (*formatPtr)++;
+ }
+
+ /*
+ * The string was empty, except for whitespace, so fail.
+ */
+
+ if (!(**formatPtr)) {
+ return 0;
+ }
+
+ /*
+ * Extract the command character and any trailing digits or '*'.
+ */
+
+ *cmdPtr = **formatPtr;
+ (*formatPtr)++;
+ if (**formatPtr == '*') {
+ (*formatPtr)++;
+ (*countPtr) = BINARY_ALL;
+ } else if (isdigit(**formatPtr)) {
+ (*countPtr) = strtoul(*formatPtr, formatPtr, 10);
+ } else {
+ (*countPtr) = BINARY_NOCOUNT;
+ }
+ return 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FormatNumber --
+ *
+ * This routine is called by Tcl_BinaryObjCmd to format a number
+ * into a location pointed at by cursor.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Moves the cursor to the next location to be written into.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FormatNumber(interp, type, src, cursorPtr)
+ Tcl_Interp *interp; /* Current interpreter, used to report
+ * errors. */
+ int type; /* Type of number to format. */
+ Tcl_Obj *src; /* Number to format. */
+ char **cursorPtr; /* Pointer to index into destination buffer. */
+{
+ int value;
+ double dvalue;
+ char cmd = (char)type;
+
+ if (cmd == 'd' || cmd == 'f') {
+ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (cmd == 'd') {
+ *((double *)(*cursorPtr)) = dvalue;
+ (*cursorPtr) += sizeof(double);
+ } else {
+ /*
+ * Because some compilers will generate floating point exceptions
+ * on an overflow cast (e.g. Borland), we restrict the values
+ * to the valid range for float.
+ */
+
+ if (dvalue > FLT_MAX) {
+ *((float *)(*cursorPtr)) = FLT_MAX;
+ } else if (dvalue < FLT_MIN) {
+ *((float *)(*cursorPtr)) = FLT_MIN;
+ } else {
+ *((float *)(*cursorPtr)) = (float)dvalue;
+ }
+ (*cursorPtr) += sizeof(float);
+ }
+ } else {
+ if (Tcl_GetIntFromObj(interp, src, &value) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (cmd == 'c') {
+ *(*cursorPtr)++ = (char)(value & 0xff);
+ } else if (cmd == 's') {
+ *(*cursorPtr)++ = (char)(value & 0xff);
+ *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
+ } else if (cmd == 'S') {
+ *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
+ *(*cursorPtr)++ = (char)(value & 0xff);
+ } else if (cmd == 'i') {
+ *(*cursorPtr)++ = (char)(value & 0xff);
+ *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
+ *(*cursorPtr)++ = (char)((value >> 16) & 0xff);
+ *(*cursorPtr)++ = (char)((value >> 24) & 0xff);
+ } else if (cmd == 'I') {
+ *(*cursorPtr)++ = (char)((value >> 24) & 0xff);
+ *(*cursorPtr)++ = (char)((value >> 16) & 0xff);
+ *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
+ *(*cursorPtr)++ = (char)(value & 0xff);
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ScanNumber --
+ *
+ * This routine is called by Tcl_BinaryObjCmd to scan a number
+ * out of a buffer.
+ *
+ * Results:
+ * Returns a newly created object containing the scanned number.
+ * This object has a ref count of zero.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+ScanNumber(buffer, type)
+ char *buffer; /* Buffer to scan number from. */
+ int type; /* Type of number to scan. */
+{
+ int c;
+
+ switch ((char) type) {
+ case 'c':
+ /*
+ * Characters need special handling. We want to produce a
+ * signed result, but on some platforms (such as AIX) chars
+ * are unsigned. To deal with this, check for a value that
+ * should be negative but isn't.
+ */
+
+ c = buffer[0];
+ if (c > 127) {
+ c -= 256;
+ }
+ return Tcl_NewIntObj(c);
+ case 's':
+ return Tcl_NewIntObj((short)(((unsigned char)buffer[0])
+ + ((unsigned char)buffer[1] << 8)));
+ case 'S':
+ return Tcl_NewIntObj((short)(((unsigned char)buffer[1])
+ + ((unsigned char)buffer[0] << 8)));
+ case 'i':
+ return Tcl_NewIntObj((long) (((unsigned char)buffer[0])
+ + ((unsigned char)buffer[1] << 8)
+ + ((unsigned char)buffer[2] << 16)
+ + ((unsigned char)buffer[3] << 24)));
+ case 'I':
+ return Tcl_NewIntObj((long) (((unsigned char)buffer[3])
+ + ((unsigned char)buffer[2] << 8)
+ + ((unsigned char)buffer[1] << 16)
+ + ((unsigned char)buffer[0] << 24)));
+ case 'f':
+ return Tcl_NewDoubleObj(*(float*)buffer);
+ case 'd':
+ return Tcl_NewDoubleObj(*(double*)buffer);
+ }
+ return NULL;
+}
diff --git a/contrib/tcl/generic/tclCkalloc.c b/contrib/tcl/generic/tclCkalloc.c
index 62744a612fdc..e32eb3ac7bfc 100644
--- a/contrib/tcl/generic/tclCkalloc.c
+++ b/contrib/tcl/generic/tclCkalloc.c
@@ -12,19 +12,16 @@
*
* This code contributed by Karl Lehenbauer and Mark Diekhans
*
- *
- * SCCS: @(#) tclCkalloc.c 1.20 96/06/06 13:48:27
+ * SCCS: @(#) tclCkalloc.c 1.28 97/04/30 12:09:04
*/
#include "tclInt.h"
+#include "tclPort.h"
#define FALSE 0
#define TRUE 1
#ifdef TCL_MEM_DEBUG
-#ifndef TCL_GENERIC_ONLY
-#include "tclPort.h"
-#endif
/*
* One of the following structures is allocated each time the
@@ -110,17 +107,20 @@ static int init_malloced_bodies = TRUE;
static int MemoryCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
+static void ValidateMemory _ANSI_ARGS_((
+ struct mem_header *memHeaderP, char *file,
+ int line, int nukeGuards));
/*
*----------------------------------------------------------------------
*
- * dump_memory_info --
+ * TclDumpMemoryInfo --
* Display the global memory management statistics.
*
*----------------------------------------------------------------------
*/
-static void
-dump_memory_info(outFile)
+void
+TclDumpMemoryInfo(outFile)
FILE *outFile;
{
fprintf(outFile,"total mallocs %10d\n",
@@ -146,7 +146,7 @@ dump_memory_info(outFile)
*----------------------------------------------------------------------
*/
static void
-ValidateMemory (memHeaderP, file, line, nukeGuards)
+ValidateMemory(memHeaderP, file, line, nukeGuards)
struct mem_header *memHeaderP;
char *file;
int line;
@@ -161,18 +161,18 @@ ValidateMemory (memHeaderP, file, line, nukeGuards)
byte = *(memHeaderP->low_guard + idx);
if (byte != GUARD_VALUE) {
guard_failed = TRUE;
- fflush (stdout);
+ fflush(stdout);
byte &= 0xff;
fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", idx, byte,
(isprint(UCHAR(byte)) ? byte : ' '));
}
}
if (guard_failed) {
- dump_memory_info (stderr);
- fprintf (stderr, "low guard failed at %lx, %s %d\n",
+ TclDumpMemoryInfo (stderr);
+ fprintf(stderr, "low guard failed at %lx, %s %d\n",
(long unsigned int) memHeaderP->body, file, line);
- fflush (stderr); /* In case name pointer is bad. */
- fprintf (stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length,
+ fflush(stderr); /* In case name pointer is bad. */
+ fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length,
memHeaderP->file, memHeaderP->line);
panic ("Memory validation failure");
}
@@ -190,14 +190,14 @@ ValidateMemory (memHeaderP, file, line, nukeGuards)
}
if (guard_failed) {
- dump_memory_info (stderr);
- fprintf (stderr, "high guard failed at %lx, %s %d\n",
+ TclDumpMemoryInfo (stderr);
+ fprintf(stderr, "high guard failed at %lx, %s %d\n",
(long unsigned int) memHeaderP->body, file, line);
- fflush (stderr); /* In case name pointer is bad. */
- fprintf (stderr, "%ld bytes allocated at (%s %d)\n",
+ fflush(stderr); /* In case name pointer is bad. */
+ fprintf(stderr, "%ld bytes allocated at (%s %d)\n",
memHeaderP->length, memHeaderP->file,
memHeaderP->line);
- panic ("Memory validation failure");
+ panic("Memory validation failure");
}
if (nukeGuards) {
@@ -223,7 +223,7 @@ Tcl_ValidateAllMemory (file, line)
struct mem_header *memScanP;
for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink)
- ValidateMemory (memScanP, file, line, FALSE);
+ ValidateMemory(memScanP, file, line, FALSE);
}
@@ -252,7 +252,7 @@ Tcl_DumpActiveMemory (fileName)
for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
address = &memScanP->body [0];
- fprintf (fileP, "%8lx - %8lx %7ld @ %s %d %s",
+ fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s",
(long unsigned int) address,
(long unsigned int) address + memScanP->length - 1,
memScanP->length, memScanP->file, memScanP->line,
@@ -292,11 +292,11 @@ Tcl_DbCkalloc(size, file, line)
if (validate_memory)
Tcl_ValidateAllMemory (file, line);
- result = (struct mem_header *)malloc((unsigned)size +
+ result = (struct mem_header *) TclpAlloc((unsigned)size +
sizeof(struct mem_header) + HIGH_GUARD_SIZE);
if (result == NULL) {
fflush(stdout);
- dump_memory_info(stderr);
+ TclDumpMemoryInfo(stderr);
panic("unable to alloc %d bytes, %s line %d", size, file,
line);
}
@@ -401,9 +401,9 @@ Tcl_DbCkfree(ptr, file, line)
(long unsigned int) memp->body, memp->length, file, line);
if (validate_memory)
- Tcl_ValidateAllMemory (file, line);
+ Tcl_ValidateAllMemory(file, line);
- ValidateMemory (memp, file, line, TRUE);
+ ValidateMemory(memp, file, line, TRUE);
if (init_malloced_bodies) {
memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length);
}
@@ -415,7 +415,7 @@ Tcl_DbCkfree(ptr, file, line)
if (memp->tagPtr != NULL) {
memp->tagPtr->refCount--;
if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) {
- free((char *) memp->tagPtr);
+ TclpFree((char *) memp->tagPtr);
}
}
@@ -428,7 +428,7 @@ Tcl_DbCkfree(ptr, file, line)
memp->blink->flink = memp->flink;
if (allocHead == memp)
allocHead = memp->flink;
- free((char *) memp);
+ TclpFree((char *) memp);
return 0;
}
@@ -463,7 +463,7 @@ Tcl_DbCkrealloc(ptr, size, file, line)
(((unsigned long) ptr) - BODY_OFFSET);
copySize = size;
- if (copySize > memp->length) {
+ if (copySize > (unsigned int) memp->length) {
copySize = memp->length;
}
new = Tcl_DbCkalloc(size, file, line);
@@ -571,19 +571,22 @@ MemoryCmd (clientData, interp, argc, argv)
return TCL_OK;
}
if (strcmp(argv[1],"break_on_malloc") == 0) {
- if (argc != 3)
+ if (argc != 3) {
goto argError;
- if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK)
- return TCL_ERROR;
+ }
+ if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
+ return TCL_ERROR;
+ }
return TCL_OK;
}
if (strcmp(argv[1],"info") == 0) {
- dump_memory_info(stdout);
+ TclDumpMemoryInfo(stdout);
return TCL_OK;
}
if (strcmp(argv[1],"init") == 0) {
- if (argc != 3)
+ if (argc != 3) {
goto bad_suboption;
+ }
init_malloced_bodies = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
@@ -594,30 +597,34 @@ MemoryCmd (clientData, interp, argc, argv)
return TCL_ERROR;
}
if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
- free((char *) curTagPtr);
+ TclpFree((char *) curTagPtr);
}
- curTagPtr = (MemTag *) malloc(TAG_SIZE(strlen(argv[2])));
+ curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(strlen(argv[2])));
curTagPtr->refCount = 0;
strcpy(curTagPtr->string, argv[2]);
return TCL_OK;
}
if (strcmp(argv[1],"trace") == 0) {
- if (argc != 3)
+ if (argc != 3) {
goto bad_suboption;
+ }
alloc_tracing = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
if (strcmp(argv[1],"trace_on_at_malloc") == 0) {
- if (argc != 3)
+ if (argc != 3) {
goto argError;
- if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK)
- return TCL_ERROR;
- return TCL_OK;
+ }
+ if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return TCL_OK;
}
if (strcmp(argv[1],"validate") == 0) {
- if (argc != 3)
- goto bad_suboption;
+ if (argc != 3) {
+ goto bad_suboption;
+ }
validate_memory = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
@@ -661,7 +668,7 @@ Tcl_InitMemory(interp)
*----------------------------------------------------------------------
*
* Tcl_Alloc --
- * Interface to malloc when TCL_MEM_DEBUG is disabled. It does check
+ * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check
* that memory was actually allocated.
*
*----------------------------------------------------------------------
@@ -673,7 +680,7 @@ Tcl_Alloc (size)
{
char *result;
- result = malloc(size);
+ result = TclpAlloc(size);
if (result == NULL)
panic("unable to alloc %d bytes", size);
return result;
@@ -687,7 +694,7 @@ Tcl_DbCkalloc(size, file, line)
{
char *result;
- result = (char *) malloc(size);
+ result = (char *) TclpAlloc(size);
if (result == NULL) {
fflush(stdout);
@@ -702,8 +709,8 @@ Tcl_DbCkalloc(size, file, line)
*----------------------------------------------------------------------
*
* Tcl_Realloc --
- * Interface to realloc when TCL_MEM_DEBUG is disabled. It does check
- * that memory was actually allocated.
+ * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does
+ * check that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
@@ -715,7 +722,7 @@ Tcl_Realloc(ptr, size)
{
char *result;
- result = realloc(ptr, size);
+ result = TclpRealloc(ptr, size);
if (result == NULL)
panic("unable to realloc %d bytes", size);
return result;
@@ -730,7 +737,7 @@ Tcl_DbCkrealloc(ptr, size, file, line)
{
char *result;
- result = (char *) realloc(ptr, size);
+ result = (char *) TclpRealloc(ptr, size);
if (result == NULL) {
fflush(stdout);
@@ -744,8 +751,8 @@ Tcl_DbCkrealloc(ptr, size, file, line)
*----------------------------------------------------------------------
*
* Tcl_Free --
- * Interface to free when TCL_MEM_DEBUG is disabled. Done here rather
- * in the macro to keep some modules from being compiled with
+ * Interface to TclpFree when TCL_MEM_DEBUG is disabled. Done here
+ * rather in the macro to keep some modules from being compiled with
* TCL_MEM_DEBUG enabled and some with it disabled.
*
*----------------------------------------------------------------------
@@ -755,7 +762,7 @@ void
Tcl_Free (ptr)
char *ptr;
{
- free (ptr);
+ TclpFree(ptr);
}
int
@@ -764,7 +771,7 @@ Tcl_DbCkfree(ptr, file, line)
char *file;
int line;
{
- free (ptr);
+ TclpFree(ptr);
return 0;
}
@@ -792,14 +799,14 @@ extern void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file,
int line));
int
-Tcl_DumpActiveMemory (fileName)
+Tcl_DumpActiveMemory(fileName)
char *fileName;
{
return TCL_OK;
}
void
-Tcl_ValidateAllMemory (file, line)
+Tcl_ValidateAllMemory(file, line)
char *file;
int line;
{
diff --git a/contrib/tcl/generic/tclClock.c b/contrib/tcl/generic/tclClock.c
index 3eaf99a16f2d..c6cb924997c6 100644
--- a/contrib/tcl/generic/tclClock.c
+++ b/contrib/tcl/generic/tclClock.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclClock.c 1.20 96/07/23 16:14:45
+ * SCCS: @(#) tclClock.c 1.36 97/06/02 10:14:17
*/
#include "tcl.h"
@@ -25,13 +25,11 @@
static int FormatClock _ANSI_ARGS_((Tcl_Interp *interp,
unsigned long clockVal, int useGMT,
char *format));
-static int ParseTime _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, unsigned long *timePtr));
/*
- *-----------------------------------------------------------------------------
+ *-------------------------------------------------------------------------
*
- * Tcl_ClockCmd --
+ * Tcl_ClockObjCmd --
*
* This procedure is invoked to process the "clock" Tcl command.
* See the user documentation for details on what it does.
@@ -42,211 +40,158 @@ static int ParseTime _ANSI_ARGS_((Tcl_Interp *interp,
* Side effects:
* See the user documentation.
*
- *-----------------------------------------------------------------------------
+ *-------------------------------------------------------------------------
*/
int
-Tcl_ClockCmd (dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
+Tcl_ClockObjCmd (client, interp, objc, objv)
+ ClientData client; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument values. */
{
- int c;
- size_t length;
- char **argPtr;
+ Tcl_Obj *resultPtr;
+ int index;
+ Tcl_Obj *CONST *objPtr;
int useGMT = 0;
- unsigned long clockVal;
+ char *format = "%a %b %d %X %Z %Y";
+ int dummy;
+ unsigned long baseClock, clockVal;
+ long zone;
+ Tcl_Obj *baseObjPtr = NULL;
+ char *scanStr;
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " option ?arg ...?\"", (char *) NULL);
+ static char *switches[] =
+ {"clicks", "format", "scan", "seconds", (char *) NULL};
+ static char *formatSwitches[] = {"-format", "-gmt", (char *) NULL};
+ static char *scanSwitches[] = {"-base", "-gmt", (char *) NULL};
+
+ resultPtr = Tcl_GetObjResult(interp);
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
- c = argv[1][0];
- length = strlen(argv[1]);
- if ((c == 'c') && (strncmp(argv[1], "clicks", length) == 0)) {
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # arguments: must be \"",
- argv[0], " clicks\"", (char *) NULL);
- return TCL_ERROR;
- }
- sprintf(interp->result, "%lu", TclpGetClicks());
- return TCL_OK;
- } else if ((c == 'f') && (strncmp(argv[1], "format", length) == 0)) {
- char *format = "%a %b %d %X %Z %Y";
-
- if ((argc < 3) || (argc > 7)) {
- wrongFmtArgs:
- Tcl_AppendResult(interp, "wrong # args: ", argv [0],
- " format clockval ?-format string? ?-gmt boolean?",
- (char *) NULL);
- return TCL_ERROR;
- }
- if (ParseTime(interp, argv[2], &clockVal) != TCL_OK) {
- return TCL_ERROR;
- }
+ if (Tcl_GetIndexFromObj(interp, objv[1], switches, "option", 0, &index)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (index) {
+ case 0: /* clicks */
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "clicks");
+ return TCL_ERROR;
+ }
+ Tcl_SetLongObj(resultPtr, (long) TclpGetClicks());
+ return TCL_OK;
+ case 1: /* format */
+ if ((objc < 3) || (objc > 7)) {
+ wrongFmtArgs:
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "format clockval ?-format string? ?-gmt boolean?");
+ return TCL_ERROR;
+ }
- argPtr = argv+3;
- argc -= 3;
- while ((argc > 1) && (argPtr[0][0] == '-')) {
- if (strcmp(argPtr[0], "-format") == 0) {
- format = argPtr[1];
- } else if (strcmp(argPtr[0], "-gmt") == 0) {
- if (Tcl_GetBoolean(interp, argPtr[1], &useGMT) != TCL_OK) {
+ if (Tcl_GetLongFromObj(interp, objv[2], (long*) &clockVal)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ objPtr = objv+3;
+ objc -= 3;
+ while (objc > 1) {
+ if (Tcl_GetIndexFromObj(interp, objPtr[0], formatSwitches,
+ "switch", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
- } else {
- Tcl_AppendResult(interp, "bad option \"", argPtr[0],
- "\": must be -format or -gmt", (char *) NULL);
+ switch (index) {
+ case 0: /* -format */
+ format = Tcl_GetStringFromObj(objPtr[1], &dummy);
+ break;
+ case 1: /* -gmt */
+ if (Tcl_GetBooleanFromObj(interp, objPtr[1],
+ &useGMT) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
+ }
+ objPtr += 2;
+ objc -= 2;
+ }
+ if (objc != 0) {
+ goto wrongFmtArgs;
+ }
+ return FormatClock(interp, (unsigned long) clockVal, useGMT,
+ format);
+ case 2: /* scan */
+ if ((objc < 3) || (objc > 7)) {
+ wrongScanArgs:
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "scan dateString ?-base clockValue? ?-gmt boolean?");
return TCL_ERROR;
}
- argPtr += 2;
- argc -= 2;
- }
- if (argc != 0) {
- goto wrongFmtArgs;
- }
-
- return FormatClock(interp, clockVal, useGMT, format);
- } else if ((c == 's') && (strncmp(argv[1], "scan", length) == 0)) {
- unsigned long baseClock;
- long zone;
- char * baseStr = NULL;
- if ((argc < 3) || (argc > 7)) {
- wrongScanArgs:
- Tcl_AppendResult (interp, "wrong # args: ", argv [0],
- " scan dateString ?-base clockValue? ?-gmt boolean?",
- (char *) NULL);
- return TCL_ERROR;
- }
+ objPtr = objv+3;
+ objc -= 3;
+ while (objc > 1) {
+ if (Tcl_GetIndexFromObj(interp, objPtr[0], scanSwitches,
+ "switch", 0, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (index) {
+ case 0: /* -base */
+ baseObjPtr = objPtr[1];
+ break;
+ case 1: /* -gmt */
+ if (Tcl_GetBooleanFromObj(interp, objPtr[1],
+ &useGMT) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
+ }
+ objPtr += 2;
+ objc -= 2;
+ }
+ if (objc != 0) {
+ goto wrongScanArgs;
+ }
- argPtr = argv+3;
- argc -= 3;
- while ((argc > 1) && (argPtr[0][0] == '-')) {
- if (strcmp(argPtr[0], "-base") == 0) {
- baseStr = argPtr[1];
- } else if (strcmp(argPtr[0], "-gmt") == 0) {
- if (Tcl_GetBoolean(interp, argPtr[1], &useGMT) != TCL_OK) {
+ if (baseObjPtr != NULL) {
+ if (Tcl_GetLongFromObj(interp, baseObjPtr,
+ (long*) &baseClock) != TCL_OK) {
return TCL_ERROR;
}
} else {
- Tcl_AppendResult(interp, "bad option \"", argPtr[0],
- "\": must be -base or -gmt", (char *) NULL);
- return TCL_ERROR;
+ baseClock = TclpGetSeconds();
}
- argPtr += 2;
- argc -= 2;
- }
- if (argc != 0) {
- goto wrongScanArgs;
- }
-
- if (baseStr != NULL) {
- if (ParseTime(interp, baseStr, &baseClock) != TCL_OK)
- return TCL_ERROR;
- } else {
- baseClock = TclpGetSeconds();
- }
-
- if (useGMT) {
- zone = -50000; /* Force GMT */
- } else {
- zone = TclpGetTimeZone(baseClock);
- }
-
- if (TclGetDate(argv[2], baseClock, zone, &clockVal) < 0) {
- Tcl_AppendResult(interp, "unable to convert date-time string \"",
- argv[2], "\"", (char *) NULL);
- return TCL_ERROR;
- }
-
- sprintf(interp->result, "%lu", (long) clockVal);
- return TCL_OK;
- } else if ((c == 's') && (strncmp(argv[1], "seconds", length) == 0)) {
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # arguments: must be \"",
- argv[0], " seconds\"", (char *) NULL);
- return TCL_ERROR;
- }
- sprintf(interp->result, "%lu", TclpGetSeconds());
- return TCL_OK;
- } else {
- Tcl_AppendResult(interp, "unknown option \"", argv[1],
- "\": must be clicks, format, scan, or seconds",
- (char *) NULL);
- return TCL_ERROR;
- }
-}
-
-/*
- *-----------------------------------------------------------------------------
- *
- * ParseTime --
- *
- * Given a string, produce the corresponding time_t value.
- *
- * Results:
- * The return value is normally TCL_OK; in this case *timePtr
- * will be set to the integer value equivalent to string. If
- * string is improperly formed then TCL_ERROR is returned and
- * an error message will be left in interp->result.
- *
- * Side effects:
- * None.
- *
- *-----------------------------------------------------------------------------
- */
-static int
-ParseTime(interp, string, timePtr)
- Tcl_Interp *interp;
- char *string;
- unsigned long *timePtr;
-{
- char *end, *p;
- unsigned long i;
+ if (useGMT) {
+ zone = -50000; /* Force GMT */
+ } else {
+ zone = TclpGetTimeZone((unsigned long) baseClock);
+ }
- /*
- * Since some strtoul functions don't detect negative numbers, check
- * in advance.
- */
- errno = 0;
- for (p = (char *) string; isspace(UCHAR(*p)); p++) {
- /* Empty loop body. */
- }
- if (*p == '+') {
- p++;
- }
- i = strtoul(p, &end, 0);
- if (end == p) {
- goto badTime;
- }
- if (errno == ERANGE) {
- interp->result = "integer value too large to represent";
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
- interp->result, (char *) NULL);
- return TCL_ERROR;
- }
- while ((*end != '\0') && isspace(UCHAR(*end))) {
- end++;
- }
- if (*end != '\0') {
- goto badTime;
- }
+ scanStr = Tcl_GetStringFromObj(objv[2], &dummy);
+ if (TclGetDate(scanStr, (unsigned long) baseClock, zone,
+ (unsigned long *) &clockVal) < 0) {
+ Tcl_AppendStringsToObj(resultPtr,
+ "unable to convert date-time string \"",
+ scanStr, "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
- *timePtr = (time_t) i;
- if (*timePtr != i) {
- goto badTime;
+ Tcl_SetLongObj(resultPtr, (long) clockVal);
+ return TCL_OK;
+ case 3: /* seconds */
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "seconds");
+ return TCL_ERROR;
+ }
+ Tcl_SetLongObj(resultPtr, (long) TclpGetSeconds());
+ return TCL_OK;
+ default:
+ return TCL_ERROR; /* Should never be reached. */
}
- return TCL_OK;
-
- badTime:
- Tcl_AppendResult (interp, "expected unsigned time but got \"",
- string, "\"", (char *) NULL);
- return TCL_ERROR;
}
/*
@@ -281,7 +226,9 @@ FormatClock(interp, clockVal, useGMT, format)
int savedTimeZone;
char *savedTZEnv;
#endif
+ Tcl_Obj *resultPtr;
+ resultPtr = Tcl_GetObjResult(interp);
#ifdef HAVE_TZSET
/*
* Some systems forgot to call tzset in localtime, make sure its done.
@@ -323,7 +270,7 @@ FormatClock(interp, clockVal, useGMT, format)
* based on the number of percents in the string.
*/
- for (bufSize = 0, p = format; *p != '\0'; p++) {
+ for (bufSize = 1, p = format; *p != '\0'; p++) {
if (*p == '%') {
bufSize += 40;
} else {
@@ -333,10 +280,10 @@ FormatClock(interp, clockVal, useGMT, format)
Tcl_DStringInit(&buffer);
Tcl_DStringSetLength(&buffer, bufSize);
- if (TclStrftime(buffer.string, (unsigned int) bufSize, format,
- timeDataPtr) == 0) {
- Tcl_DStringFree(&buffer);
- Tcl_AppendResult(interp, "bad format string", (char *)NULL);
+ if ((TclStrftime(buffer.string, (unsigned int) bufSize, format,
+ timeDataPtr) == 0) && (*format != '\0')) {
+ Tcl_AppendStringsToObj(resultPtr, "bad format string \"",
+ format, "\"", (char *) NULL);
return TCL_ERROR;
}
@@ -353,7 +300,8 @@ FormatClock(interp, clockVal, useGMT, format)
}
#endif
- Tcl_DStringResult(interp, &buffer);
+ Tcl_SetStringObj(resultPtr, buffer.string, -1);
+ Tcl_DStringFree(&buffer);
return TCL_OK;
}
diff --git a/contrib/tcl/generic/tclCmdAH.c b/contrib/tcl/generic/tclCmdAH.c
index 6b76d82b57b8..46384c905ba1 100644
--- a/contrib/tcl/generic/tclCmdAH.c
+++ b/contrib/tcl/generic/tclCmdAH.c
@@ -6,12 +6,12 @@
* A to H.
*
* Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCmdAH.c 1.111 96/07/30 09:33:59
+ * SCCS: @(#) tclCmdAH.c 1.146 97/06/26 13:45:20
*/
#include "tclInt.h"
@@ -33,6 +33,10 @@ static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
* This procedure is invoked to process the "break" Tcl command.
* See the user documentation for details on what it does.
*
+ * With the bytecode compiler, this procedure is only called when
+ * a command name is computed at runtime, and is "break" or the name
+ * to which "break" was renamed: e.g., "set z break; $z"
+ *
* Results:
* A standard Tcl result.
*
@@ -61,13 +65,13 @@ Tcl_BreakCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_CaseCmd --
+ * Tcl_CaseObjCmd --
*
* This procedure is invoked to process the "case" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
* See the user documentation.
@@ -77,57 +81,64 @@ Tcl_BreakCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_CaseCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_CaseObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int i, result;
- int body;
- char *string;
- int caseArgc, splitArgs;
- char **caseArgv;
-
- if (argc < 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " string ?in? patList body ... ?default body?\"",
- (char *) NULL);
+ register int i;
+ int body, result;
+ char *string, *arg;
+ int argLen, caseObjc;
+ Tcl_Obj *CONST *caseObjv;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "string ?in? patList body ... ?default body?");
return TCL_ERROR;
}
- string = argv[1];
+
+ /*
+ * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
+ */
+
+ string = Tcl_GetStringFromObj(objv[1], &argLen);
body = -1;
- if (strcmp(argv[2], "in") == 0) {
+
+ arg = Tcl_GetStringFromObj(objv[2], &argLen);
+ if (strcmp(arg, "in") == 0) {
i = 3;
} else {
i = 2;
}
- caseArgc = argc - i;
- caseArgv = argv + i;
+ caseObjc = objc - i;
+ caseObjv = objv + i;
/*
* If all of the pattern/command pairs are lumped into a single
* argument, split them out again.
+ * THIS FAILS IF THE ARG'S STRING REP CONTAINS A NULL
*/
- splitArgs = 0;
- if (caseArgc == 1) {
- result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv);
- if (result != TCL_OK) {
- return result;
- }
- splitArgs = 1;
+ if (caseObjc == 1) {
+ Tcl_Obj **newObjv;
+
+ Tcl_ListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);
+ caseObjv = newObjv;
}
- for (i = 0; i < caseArgc; i += 2) {
- int patArgc, j;
- char **patArgv;
+ for (i = 0; i < caseObjc; i += 2) {
+ int patObjc, j;
+ char **patObjv;
+ char *pat;
register char *p;
- if (i == (caseArgc-1)) {
- interp->result = "extra case pattern with no body";
- result = TCL_ERROR;
- goto cleanup;
+ if (i == (caseObjc-1)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "extra case pattern with no body", -1);
+ return TCL_ERROR;
}
/*
@@ -135,79 +146,76 @@ Tcl_CaseCmd(dummy, interp, argc, argv)
* no backslash sequences.
*/
- for (p = caseArgv[i]; *p != 0; p++) {
+ pat = Tcl_GetStringFromObj(caseObjv[i], &argLen);
+ for (p = pat; *p != 0; p++) { /* FAILS IF NULL BYTE */
if (isspace(UCHAR(*p)) || (*p == '\\')) {
break;
}
}
if (*p == 0) {
- if ((*caseArgv[i] == 'd')
- && (strcmp(caseArgv[i], "default") == 0)) {
+ if ((*pat == 'd') && (strcmp(pat, "default") == 0)) {
body = i+1;
}
- if (Tcl_StringMatch(string, caseArgv[i])) {
+ if (Tcl_StringMatch(string, pat)) {
body = i+1;
goto match;
}
continue;
}
+
/*
* Break up pattern lists, then check each of the patterns
* in the list.
*/
- result = Tcl_SplitList(interp, caseArgv[i], &patArgc, &patArgv);
+ result = Tcl_SplitList(interp, pat, &patObjc, &patObjv);
if (result != TCL_OK) {
- goto cleanup;
+ return result;
}
- for (j = 0; j < patArgc; j++) {
- if (Tcl_StringMatch(string, patArgv[j])) {
+ for (j = 0; j < patObjc; j++) {
+ if (Tcl_StringMatch(string, patObjv[j])) {
body = i+1;
break;
}
}
- ckfree((char *) patArgv);
- if (j < patArgc) {
+ ckfree((char *) patObjv);
+ if (j < patObjc) {
break;
}
}
match:
if (body != -1) {
- result = Tcl_Eval(interp, caseArgv[body]);
+ result = Tcl_EvalObj(interp, caseObjv[body]);
if (result == TCL_ERROR) {
char msg[100];
- sprintf(msg, "\n (\"%.50s\" arm line %d)", caseArgv[body-1],
- interp->errorLine);
- Tcl_AddErrorInfo(interp, msg);
+
+ arg = Tcl_GetStringFromObj(caseObjv[body-1], &argLen);
+ sprintf(msg, "\n (\"%.*s\" arm line %d)", argLen, arg,
+ interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
}
- goto cleanup;
+ return result;
}
/*
- * Nothing matched: return nothing.
+ * Nothing matched: return nothing.
*/
- result = TCL_OK;
-
- cleanup:
- if (splitArgs) {
- ckfree((char *) caseArgv);
- }
- return result;
+ return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_CatchCmd --
+ * Tcl_CatchObjCmd --
*
- * This procedure is invoked to process the "catch" Tcl command.
- * See the user documentation for details on what it does.
+ * This object-based procedure is invoked to process the "catch" Tcl
+ * command. See the user documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
* See the user documentation.
@@ -217,29 +225,45 @@ Tcl_CaseCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_CatchCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_CatchObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result;
- if ((argc != 2) && (argc != 3)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " command ?varName?\"", (char *) NULL);
+ if ((objc != 2) && (objc != 3)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "command ?varName?");
return TCL_ERROR;
}
- result = Tcl_Eval(interp, argv[1]);
- if (argc == 3) {
- if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) {
- Tcl_SetResult(interp, "couldn't save command result in variable",
- TCL_STATIC);
+
+ /*
+ * Save a pointer to the variable name object, if any, in case the
+ * Tcl_EvalObj reallocates the bytecode interpreter's evaluation
+ * stack rendering objv invalid.
+ */
+
+ result = Tcl_EvalObj(interp, objv[1]);
+ if (objc == 3) {
+ if (Tcl_ObjSetVar2(interp, objv[2], NULL, Tcl_GetObjResult(interp),
+ TCL_PARSE_PART1) == NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "couldn't save command result in variable", -1);
return TCL_ERROR;
}
}
+
+ /*
+ * Set the interpreter's object result to an integer object holding the
+ * integer Tcl_EvalObj result. Note that we don't bother generating a
+ * string representation. We reset the interpreter's object result
+ * to an unshared empty object and then set it to be an integer object.
+ */
+
Tcl_ResetResult(interp);
- sprintf(interp->result, "%d", result);
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), result);
return TCL_OK;
}
@@ -295,13 +319,13 @@ Tcl_CdCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_ConcatCmd --
+ * Tcl_ConcatObjCmd --
*
- * This procedure is invoked to process the "concat" Tcl command.
- * See the user documentation for details on what it does.
+ * This object-based procedure is invoked to process the "concat" Tcl
+ * command. See the user documentation for details on what it does/
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
* See the user documentation.
@@ -311,15 +335,14 @@ Tcl_CdCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_ConcatCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_ConcatObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- if (argc >= 2) {
- interp->result = Tcl_Concat(argc-1, argv+1);
- interp->freeProc = TCL_DYNAMIC;
+ if (objc >= 2) {
+ Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1));
}
return TCL_OK;
}
@@ -327,11 +350,15 @@ Tcl_ConcatCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_ContinueCmd --
+ * Tcl_ContinueCmd -
*
* This procedure is invoked to process the "continue" Tcl command.
* See the user documentation for details on what it does.
*
+ * With the bytecode compiler, this procedure is only called when
+ * a command name is computed at runtime, and is "continue" or the name
+ * to which "continue" was renamed: e.g., "set z continue; $z"
+ *
* Results:
* A standard Tcl result.
*
@@ -360,13 +387,13 @@ Tcl_ContinueCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_ErrorCmd --
+ * Tcl_ErrorObjCmd --
*
* This procedure is invoked to process the "error" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
* See the user documentation.
@@ -376,42 +403,52 @@ Tcl_ContinueCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_ErrorCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_ErrorObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
+ register Tcl_Obj *namePtr;
+ char *info;
+ int infoLen;
- if ((argc < 2) || (argc > 4)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " message ?errorInfo? ?errorCode?\"", (char *) NULL);
+ if ((objc < 2) || (objc > 4)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?");
return TCL_ERROR;
}
- if ((argc >= 3) && (argv[2][0] != 0)) {
- Tcl_AddErrorInfo(interp, argv[2]);
- iPtr->flags |= ERR_ALREADY_LOGGED;
+
+ if (objc >= 3) { /* process the optional info argument */
+ info = Tcl_GetStringFromObj(objv[2], &infoLen);
+ if (*info != 0) {
+ Tcl_AddObjErrorInfo(interp, info, infoLen);
+ iPtr->flags |= ERR_ALREADY_LOGGED;
+ }
}
- if (argc == 4) {
- Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3],
+
+ if (objc == 4) {
+ namePtr = Tcl_NewStringObj("errorCode", -1);
+ Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, objv[3],
TCL_GLOBAL_ONLY);
iPtr->flags |= ERROR_CODE_SET;
+ Tcl_DecrRefCount(namePtr); /* we're done with name object */
}
- Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
+
+ Tcl_SetObjResult(interp, objv[1]);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_EvalCmd --
+ * Tcl_EvalObjCmd --
*
- * This procedure is invoked to process the "eval" Tcl command.
- * See the user documentation for details on what it does.
+ * This object-based procedure is invoked to process the "eval" Tcl
+ * command. See the user documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
* See the user documentation.
@@ -421,37 +458,36 @@ Tcl_ErrorCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_EvalCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_EvalObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result;
- char *cmd;
+ register Tcl_Obj *objPtr;
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " arg ?arg ...?\"", (char *) NULL);
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
return TCL_ERROR;
}
- if (argc == 2) {
- result = Tcl_Eval(interp, argv[1]);
- } else {
+ if (objc == 2) {
+ result = Tcl_EvalObj(interp, objv[1]);
+ } else {
/*
- * More than one argument: concatenate them together with spaces
+ * More than one argument: concatenate them together with spaces
* between, then evaluate the result.
*/
- cmd = Tcl_Concat(argc-1, argv+1);
- result = Tcl_Eval(interp, cmd);
- ckfree(cmd);
+ objPtr = Tcl_ConcatObj(objc-1, objv+1);
+ result = Tcl_EvalObj(interp, objPtr);
+ TclDecrRefCount(objPtr); /* we're done with the object */
}
if (result == TCL_ERROR) {
char msg[60];
sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine);
- Tcl_AddErrorInfo(interp, msg);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
}
return result;
}
@@ -459,13 +495,13 @@ Tcl_EvalCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_ExitCmd --
+ * Tcl_ExitObjCmd --
*
* This procedure is invoked to process the "exit" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
* See the user documentation.
@@ -475,22 +511,22 @@ Tcl_EvalCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_ExitCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_ExitObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int value;
- if ((argc != 1) && (argc != 2)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ?returnCode?\"", (char *) NULL);
+ if ((objc != 1) && (objc != 2)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
return TCL_ERROR;
}
- if (argc == 1) {
+
+ if (objc == 1) {
value = 0;
- } else if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) {
+ } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
return TCL_ERROR;
}
Tcl_Exit(value);
@@ -501,13 +537,20 @@ Tcl_ExitCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_ExprCmd --
+ * Tcl_ExprObjCmd --
*
- * This procedure is invoked to process the "expr" Tcl command.
- * See the user documentation for details on what it does.
+ * This object-based procedure is invoked to process the "expr" Tcl
+ * command. See the user documentation for details on what it does.
+ *
+ * With the bytecode compiler, this procedure is called in two
+ * circumstances: 1) to execute expr commands that are too complicated
+ * or too unsafe to try compiling directly into an inline sequence of
+ * instructions, and 2) to execute commands where the command name is
+ * computed at runtime and is "expr" or the name to which "expr" was
+ * renamed (e.g., "set z expr; $z 2+3")
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
* See the user documentation.
@@ -517,42 +560,71 @@ Tcl_ExitCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_ExprCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_ExprObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Tcl_DString buffer;
- int i, result;
+ register Tcl_Obj *objPtr;
+ Tcl_Obj *resultPtr;
+ register char *bytes;
+ int length, i, result;
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " arg ?arg ...?\"", (char *) NULL);
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
return TCL_ERROR;
}
- if (argc == 2) {
- return Tcl_ExprString(interp, argv[1]);
+ if (objc == 2) {
+ result = Tcl_ExprObj(interp, objv[1], &resultPtr);
+ if (result == TCL_OK) {
+ Tcl_SetObjResult(interp, resultPtr);
+ Tcl_DecrRefCount(resultPtr); /* done with the result object */
+ }
}
- Tcl_DStringInit(&buffer);
- Tcl_DStringAppend(&buffer, argv[1], -1);
- for (i = 2; i < argc; i++) {
- Tcl_DStringAppend(&buffer, " ", 1);
- Tcl_DStringAppend(&buffer, argv[i], -1);
+
+ /*
+ * Create a new object holding the concatenated argument strings.
+ * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
+ */
+
+ bytes = Tcl_GetStringFromObj(objv[1], &length);
+ objPtr = Tcl_NewStringObj(bytes, length);
+ Tcl_IncrRefCount(objPtr);
+ for (i = 2; i < objc; i++) {
+ Tcl_AppendToObj(objPtr, " ", 1);
+ bytes = Tcl_GetStringFromObj(objv[i], &length);
+ Tcl_AppendToObj(objPtr, bytes, length);
}
- result = Tcl_ExprString(interp, buffer.string);
- Tcl_DStringFree(&buffer);
+
+ /*
+ * Evaluate the concatenated string object.
+ */
+
+ result = Tcl_ExprObj(interp, objPtr, &resultPtr);
+ if (result == TCL_OK) {
+ Tcl_SetObjResult(interp, resultPtr);
+ Tcl_DecrRefCount(resultPtr); /* done with the result object */
+ }
+
+ /*
+ * Free allocated resources.
+ */
+
+ TclDecrRefCount(objPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_FileCmd --
+ * Tcl_FileObjCmd --
*
* This procedure is invoked to process the "file" Tcl command.
* See the user documentation for details on what it does.
+ * PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH
+ * EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC.
*
* Results:
* A standard Tcl result.
@@ -565,387 +637,492 @@ Tcl_ExprCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_FileCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_FileObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *fileName, *extension;
- int c, statOp, result;
- size_t length;
+ char *fileName, *extension, *errorString;
+ int statOp = 0; /* Init. to avoid compiler warning. */
+ int length;
int mode = 0; /* Initialized only to prevent
* compiler warning message. */
struct stat statBuf;
Tcl_DString buffer;
+ Tcl_Obj *resultPtr;
+ int index, result;
- if (argc < 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option name ?arg ...?\"", (char *) NULL);
- return TCL_ERROR;
+/*
+ * This list of constants should match the fileOption string array below.
+ */
+
+enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME,
+ FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION, FILE_ISDIRECTORY,
+ FILE_ISFILE, FILE_JOIN, FILE_LSTAT, FILE_MTIME, FILE_MKDIR,
+ FILE_NATIVENAME, FILE_OWNED, FILE_PATHTYPE, FILE_READABLE,
+ FILE_READLINK, FILE_RENAME, FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT,
+ FILE_STAT, FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE};
+
+
+ static char *fileOptions[] = {"atime", "attributes", "copy", "delete",
+ "dirname", "executable", "exists", "extension", "isdirectory",
+ "isfile", "join", "lstat", "mtime", "mkdir", "nativename",
+ "owned", "pathtype", "readable", "readlink", "rename",
+ "rootname", "size", "split", "stat", "tail", "type", "volumes",
+ "writable", (char *) NULL};
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, &index)
+ != TCL_OK) {
+ return TCL_ERROR;
}
- c = argv[1][0];
- length = strlen(argv[1]);
+
result = TCL_OK;
+ /*
+ * First, do the volumes command, since it is the only one that
+ * has objc == 2.
+ */
+
+ if ( index == FILE_VOLUMES) {
+ if ( objc != 2 ) {
+ Tcl_WrongNumArgs(interp, 1, objv, "volumes");
+ return TCL_ERROR;
+ }
+ result = TclpListVolumes(interp);
+ return result;
+ }
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name ?arg ...?");
+ return TCL_ERROR;
+ }
+
Tcl_DStringInit(&buffer);
+ resultPtr = Tcl_GetObjResult(interp);
+
/*
- * First handle operations on the file name.
+ * Handle operations on the file name.
*/
+
+ switch (index) {
+ case FILE_ATTRIBUTES:
+ result = TclFileAttrsCmd(interp, objc - 2, objv + 2);
+ goto done;
+ case FILE_DIRNAME: {
+ int pargc;
+ char **pargv;
+
+ if (objc != 3) {
+ errorString = "dirname name";
+ goto not3Args;
+ }
- if ((c == 'd') && (strncmp(argv[1], "dirname", length) == 0)) {
- int pargc;
- char **pargv;
-
- if (argc != 3) {
- argv[1] = "dirname";
- goto not3Args;
- }
-
- fileName = argv[2];
+ fileName = Tcl_GetStringFromObj(objv[2], &length);
- /*
- * If there is only one element, and it starts with a tilde,
- * perform tilde substitution and resplit the path.
- */
+ /*
+ * If there is only one element, and it starts with a tilde,
+ * perform tilde substitution and resplit the path.
+ */
- Tcl_SplitPath(fileName, &pargc, &pargv);
- if ((pargc == 1) && (*fileName == '~')) {
- ckfree((char*) pargv);
- fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
- if (fileName == NULL) {
- result = TCL_ERROR;
- goto done;
- }
Tcl_SplitPath(fileName, &pargc, &pargv);
- Tcl_DStringSetLength(&buffer, 0);
- }
+ if ((pargc == 1) && (*fileName == '~')) {
+ ckfree((char*) pargv);
+ fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
+ if (fileName == NULL) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ Tcl_SplitPath(fileName, &pargc, &pargv);
+ Tcl_DStringSetLength(&buffer, 0);
+ }
- /*
- * Return all but the last component. If there is only one
- * component, return it if the path was non-relative, otherwise
- * return the current directory.
- */
+ /*
+ * Return all but the last component. If there is only one
+ * component, return it if the path was non-relative, otherwise
+ * return the current directory.
+ */
- if (pargc > 1) {
- Tcl_JoinPath(pargc-1, pargv, &buffer);
- Tcl_DStringResult(interp, &buffer);
- } else if ((pargc == 0)
- || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) {
- Tcl_SetResult(interp,
- (tclPlatform == TCL_PLATFORM_MAC) ? ":" : ".", TCL_STATIC);
- } else {
- Tcl_SetResult(interp, pargv[0], TCL_VOLATILE);
+ if (pargc > 1) {
+ Tcl_JoinPath(pargc-1, pargv, &buffer);
+ Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer),
+ buffer.length);
+ } else if ((pargc == 0)
+ || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) {
+ Tcl_SetStringObj(resultPtr, (tclPlatform == TCL_PLATFORM_MAC)
+ ? ":" : ".", 1);
+ } else {
+ Tcl_SetStringObj(resultPtr, pargv[0], -1); }
+ ckfree((char *)pargv);
+ goto done;
}
- ckfree((char *)pargv);
- goto done;
+ case FILE_TAIL: {
+ int pargc;
+ char **pargv;
- } else if ((c == 't') && (strncmp(argv[1], "tail", length) == 0)
- && (length >= 2)) {
- int pargc;
- char **pargv;
+ if (objc != 3) {
+ errorString = "tail name";
+ goto not3Args;
+ }
+
+ fileName = Tcl_GetStringFromObj(objv[2], &length);
- if (argc != 3) {
- argv[1] = "tail";
- goto not3Args;
- }
+ /*
+ * If there is only one element, and it starts with a tilde,
+ * perform tilde substitution and resplit the path.
+ */
- fileName = argv[2];
+ Tcl_SplitPath(fileName, &pargc, &pargv);
+ if ((pargc == 1) && (*fileName == '~')) {
+ ckfree((char*) pargv);
+ fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
+ if (fileName == NULL) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ Tcl_SplitPath(fileName, &pargc, &pargv);
+ Tcl_DStringSetLength(&buffer, 0);
+ }
- /*
- * If there is only one element, and it starts with a tilde,
- * perform tilde substitution and resplit the path.
- */
+ /*
+ * Return the last component, unless it is the only component, and it
+ * is the root of an absolute path.
+ */
- Tcl_SplitPath(fileName, &pargc, &pargv);
- if ((pargc == 1) && (*fileName == '~')) {
- ckfree((char*) pargv);
- fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
- if (fileName == NULL) {
- result = TCL_ERROR;
- goto done;
+ if (pargc > 0) {
+ if ((pargc > 1)
+ || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) {
+ Tcl_SetStringObj(resultPtr, pargv[pargc - 1], -1);
+ }
}
- Tcl_SplitPath(fileName, &pargc, &pargv);
- Tcl_DStringSetLength(&buffer, 0);
+ ckfree((char *)pargv);
+ goto done;
}
-
- /*
- * Return the last component, unless it is the only component, and it
- * is the root of an absolute path.
- */
-
- if (pargc > 0) {
- if ((pargc > 1)
- || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) {
- Tcl_SetResult(interp, pargv[pargc-1], TCL_VOLATILE);
+ case FILE_ROOTNAME: {
+ char *fileName;
+
+ if (objc != 3) {
+ errorString = "rootname name";
+ goto not3Args;
+ }
+
+ fileName = Tcl_GetStringFromObj(objv[2], &length);
+ extension = TclGetExtension(fileName);
+ if (extension == NULL) {
+ Tcl_SetObjResult(interp, objv[2]);
+ } else {
+ Tcl_SetStringObj(resultPtr, fileName,
+ (int) (length - strlen(extension)));
}
+ goto done;
}
- ckfree((char *)pargv);
- goto done;
+ case FILE_EXTENSION:
+ if (objc != 3) {
+ errorString = "extension name";
+ goto not3Args;
+ }
+ extension = TclGetExtension(Tcl_GetStringFromObj(objv[2], &length));
- } else if ((c == 'r') && (strncmp(argv[1], "rootname", length) == 0)
- && (length >= 2)) {
- char tmp;
- if (argc != 3) {
- argv[1] = "rootname";
- goto not3Args;
- }
- extension = TclGetExtension(argv[2]);
- if (extension == NULL) {
- Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
- } else {
- tmp = *extension;
- *extension = 0;
- Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
- *extension = tmp;
- }
- goto done;
- } else if ((c == 'e') && (strncmp(argv[1], "extension", length) == 0)
- && (length >= 3)) {
- if (argc != 3) {
- argv[1] = "extension";
- goto not3Args;
+ if (extension != NULL) {
+ Tcl_SetStringObj(resultPtr, extension, (int) strlen(extension));
+ }
+ goto done;
+ case FILE_PATHTYPE:
+ if (objc != 3) {
+ errorString = "pathtype name";
+ goto not3Args;
+ }
+ switch (Tcl_GetPathType(Tcl_GetStringFromObj(objv[2], &length))) {
+ case TCL_PATH_ABSOLUTE:
+ Tcl_SetStringObj(resultPtr, "absolute", -1);
+ break;
+ case TCL_PATH_RELATIVE:
+ Tcl_SetStringObj(resultPtr, "relative", -1);
+ break;
+ case TCL_PATH_VOLUME_RELATIVE:
+ Tcl_SetStringObj(resultPtr, "volumerelative", -1);
+ break;
+ }
+ goto done;
+ case FILE_SPLIT: {
+ int pargc, i;
+ char **pargvList;
+ Tcl_Obj *listObjPtr;
+
+ if (objc != 3) {
+ errorString = "split name";
+ goto not3Args;
+ }
+
+ Tcl_SplitPath(Tcl_GetStringFromObj(objv[2], &length), &pargc,
+ &pargvList);
+ listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ for (i = 0; i < pargc; i++) {
+ Tcl_ListObjAppendElement(interp, listObjPtr,
+ Tcl_NewStringObj(pargvList[i], -1));
+ }
+ ckfree((char *) pargvList);
+ Tcl_SetObjResult(interp, listObjPtr);
+ goto done;
}
- extension = TclGetExtension(argv[2]);
-
- if (extension != NULL) {
- Tcl_SetResult(interp, extension, TCL_VOLATILE);
+ case FILE_JOIN: {
+ char **pargv = (char **) ckalloc((objc - 2) * sizeof(char *));
+ int i;
+
+ for (i = 2; i < objc; i++) {
+ pargv[i - 2] = Tcl_GetStringFromObj(objv[i], &length);
+ }
+ Tcl_JoinPath(objc - 2, pargv, &buffer);
+ Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer), buffer.length);
+ ckfree((char *) pargv);
+ Tcl_DStringFree(&buffer);
+ goto done;
}
- goto done;
- } else if ((c == 'p') && (strncmp(argv[1], "pathtype", length) == 0)) {
- if (argc != 3) {
- argv[1] = "pathtype";
- goto not3Args;
+ case FILE_RENAME: {
+ char **pargv = (char **) ckalloc(objc * sizeof(char *));
+ int i;
+
+ for (i = 0; i < objc; i++) {
+ pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
+ }
+ result = TclFileRenameCmd(interp, objc, pargv);
+ ckfree((char *) pargv);
+ goto done;
}
- switch (Tcl_GetPathType(argv[2])) {
- case TCL_PATH_ABSOLUTE:
- Tcl_SetResult(interp, "absolute", TCL_STATIC);
- break;
- case TCL_PATH_RELATIVE:
- Tcl_SetResult(interp, "relative", TCL_STATIC);
- break;
- case TCL_PATH_VOLUME_RELATIVE:
- Tcl_SetResult(interp, "volumerelative", TCL_STATIC);
- break;
+ case FILE_MKDIR: {
+ char **pargv = (char **) ckalloc(objc * sizeof(char *));
+ int i;
+
+ for (i = 0; i < objc; i++) {
+ pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
+ }
+ result = TclFileMakeDirsCmd(interp, objc, pargv);
+ ckfree((char *) pargv);
+ goto done;
}
- goto done;
- } else if ((c == 's') && (strncmp(argv[1], "split", length) == 0)
- && (length >= 2)) {
- int pargc, i;
- char **pargvList;
-
- if (argc != 3) {
- argv[1] = "split";
- goto not3Args;
+ case FILE_DELETE: {
+ char **pargv = (char **) ckalloc(objc * sizeof(char *));
+ int i;
+
+ for (i = 0; i < objc; i++) {
+ pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
+ }
+ result = TclFileDeleteCmd(interp, objc, pargv);
+ ckfree((char *) pargv);
+ goto done;
}
-
- Tcl_SplitPath(argv[2], &pargc, &pargvList);
- for (i = 0; i < pargc; i++) {
- Tcl_AppendElement(interp, pargvList[i]);
+ case FILE_COPY: {
+ char **pargv = (char **) ckalloc(objc * sizeof(char *));
+ int i;
+
+ for (i = 0; i < objc; i++) {
+ pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
+ }
+ result = TclFileCopyCmd(interp, objc, pargv);
+ ckfree((char *) pargv);
+ goto done;
}
- ckfree((char *) pargvList);
- goto done;
- } else if ((c == 'j') && (strncmp(argv[1], "join", length) == 0)) {
- Tcl_JoinPath(argc-2, argv+2, &buffer);
- Tcl_DStringResult(interp, &buffer);
- goto done;
+ case FILE_NATIVENAME:
+ fileName = Tcl_TranslateFileName(interp,
+ Tcl_GetStringFromObj(objv[2], &length), &buffer);
+ Tcl_SetStringObj(resultPtr, fileName, -1);
+ goto done;
}
-
+
/*
* Next, handle operations that can be satisfied with the "access"
* kernel call.
*/
- fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
- if (fileName == NULL) {
- result = TCL_ERROR;
- goto done;
- }
- if ((c == 'r') && (strncmp(argv[1], "readable", length) == 0)
- && (length >= 5)) {
- if (argc != 3) {
- argv[1] = "readable";
- goto not3Args;
- }
- mode = R_OK;
- checkAccess:
- if (access(fileName, mode) == -1) {
- interp->result = "0";
- } else {
- interp->result = "1";
- }
- goto done;
- } else if ((c == 'w') && (strncmp(argv[1], "writable", length) == 0)) {
- if (argc != 3) {
- argv[1] = "writable";
- goto not3Args;
- }
- mode = W_OK;
- goto checkAccess;
- } else if ((c == 'e') && (strncmp(argv[1], "executable", length) == 0)
- && (length >= 3)) {
- if (argc != 3) {
- argv[1] = "executable";
- goto not3Args;
- }
- mode = X_OK;
- goto checkAccess;
- } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)
- && (length >= 3)) {
- if (argc != 3) {
- argv[1] = "exists";
- goto not3Args;
- }
- mode = F_OK;
- goto checkAccess;
+ fileName = Tcl_TranslateFileName(interp,
+ Tcl_GetStringFromObj(objv[2], &length), &buffer);
+
+ switch (index) {
+ case FILE_READABLE:
+ if (objc != 3) {
+ errorString = "readable name";
+ goto not3Args;
+ }
+ mode = R_OK;
+checkAccess:
+ Tcl_SetBooleanObj(resultPtr, !((fileName == NULL)
+ || (access(fileName, mode) == -1)));
+ goto done;
+ case FILE_WRITABLE:
+ if (objc != 3) {
+ errorString = "writable name";
+ goto not3Args;
+ }
+ mode = W_OK;
+ goto checkAccess;
+ case FILE_EXECUTABLE:
+ if (objc != 3) {
+ errorString = "executable name";
+ goto not3Args;
+ }
+ mode = X_OK;
+ goto checkAccess;
+ case FILE_EXISTS:
+ if (objc != 3) {
+ errorString = "exists name";
+ goto not3Args;
+ }
+ mode = F_OK;
+ goto checkAccess;
}
+
/*
* Lastly, check stuff that requires the file to be stat-ed.
*/
- if ((c == 'a') && (strncmp(argv[1], "atime", length) == 0)) {
- if (argc != 3) {
- argv[1] = "atime";
- goto not3Args;
- }
- if (stat(fileName, &statBuf) == -1) {
- goto badStat;
- }
- sprintf(interp->result, "%ld", (long) statBuf.st_atime);
+ if (fileName == NULL) {
+ result = TCL_ERROR;
goto done;
- } else if ((c == 'i') && (strncmp(argv[1], "isdirectory", length) == 0)
- && (length >= 3)) {
- if (argc != 3) {
- argv[1] = "isdirectory";
- goto not3Args;
- }
- statOp = 2;
- } else if ((c == 'i') && (strncmp(argv[1], "isfile", length) == 0)
- && (length >= 3)) {
- if (argc != 3) {
- argv[1] = "isfile";
- goto not3Args;
- }
- statOp = 1;
- } else if ((c == 'l') && (strncmp(argv[1], "lstat", length) == 0)) {
- if (argc != 4) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " lstat name varName\"", (char *) NULL);
- result = TCL_ERROR;
+ }
+
+ switch (index) {
+ case FILE_ATIME:
+ if (objc != 3) {
+ errorString = "atime name";
+ goto not3Args;
+ }
+
+ if (stat(fileName, &statBuf) == -1) {
+ goto badStat;
+ }
+ Tcl_SetLongObj(resultPtr, (long) statBuf.st_atime);
goto done;
- }
-
- if (lstat(fileName, &statBuf) == -1) {
- Tcl_AppendResult(interp, "couldn't lstat \"", argv[2],
- "\": ", Tcl_PosixError(interp), (char *) NULL);
- result = TCL_ERROR;
+ case FILE_ISDIRECTORY:
+ if (objc != 3) {
+ errorString = "isdirectory name";
+ goto not3Args;
+ }
+ statOp = 2;
+ break;
+ case FILE_ISFILE:
+ if (objc != 3) {
+ errorString = "isfile name";
+ goto not3Args;
+ }
+ statOp = 1;
+ break;
+ case FILE_LSTAT:
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "lstat name varName");
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ if (lstat(fileName, &statBuf) == -1) {
+ Tcl_AppendStringsToObj(resultPtr, "couldn't lstat \"",
+ Tcl_GetStringFromObj(objv[2], &length), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ result = StoreStatData(interp, Tcl_GetStringFromObj(objv[3],
+ &length), &statBuf);
+ goto done;
+ case FILE_MTIME:
+ if (objc != 3) {
+ errorString = "mtime name";
+ goto not3Args;
+ }
+ if (stat(fileName, &statBuf) == -1) {
+ goto badStat;
+ }
+ Tcl_SetLongObj(resultPtr, (long) statBuf.st_mtime);
goto done;
- }
- result = StoreStatData(interp, argv[3], &statBuf);
- goto done;
- } else if ((c == 'm') && (strncmp(argv[1], "mtime", length) == 0)) {
- if (argc != 3) {
- argv[1] = "mtime";
- goto not3Args;
- }
- if (stat(fileName, &statBuf) == -1) {
- goto badStat;
- }
- sprintf(interp->result, "%ld", (long) statBuf.st_mtime);
- goto done;
- } else if ((c == 'o') && (strncmp(argv[1], "owned", length) == 0)) {
- if (argc != 3) {
- argv[1] = "owned";
- goto not3Args;
- }
- statOp = 0;
- } else if ((c == 'r') && (strncmp(argv[1], "readlink", length) == 0)
- && (length >= 5)) {
- char linkValue[MAXPATHLEN+1];
- int linkLength;
-
- if (argc != 3) {
- argv[1] = "readlink";
- goto not3Args;
- }
+ case FILE_OWNED:
+ if (objc != 3) {
+ errorString = "owned name";
+ goto not3Args;
+ }
+ statOp = 0;
+ break;
+ case FILE_READLINK: {
+ char linkValue[MAXPATHLEN + 1];
+ int linkLength;
+
+ if (objc != 3) {
+ errorString = "readlink name";
+ goto not3Args;
+ }
- /*
- * If S_IFLNK isn't defined it means that the machine doesn't
- * support symbolic links, so the file can't possibly be a
- * symbolic link. Generate an EINVAL error, which is what
- * happens on machines that do support symbolic links when
- * you invoke readlink on a file that isn't a symbolic link.
- */
+ /*
+ * If S_IFLNK isn't defined it means that the machine doesn't
+ * support symbolic links, so the file can't possibly be a
+ * symbolic link. Generate an EINVAL error, which is what
+ * happens on machines that do support symbolic links when
+ * you invoke readlink on a file that isn't a symbolic link.
+ */
#ifndef S_IFLNK
- linkLength = -1;
- errno = EINVAL;
+ linkLength = -1;
+ errno = EINVAL;
#else
- linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1);
+ linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1);
#endif /* S_IFLNK */
- if (linkLength == -1) {
- Tcl_AppendResult(interp, "couldn't readlink \"", argv[2],
- "\": ", Tcl_PosixError(interp), (char *) NULL);
- result = TCL_ERROR;
+ if (linkLength == -1) {
+ Tcl_AppendStringsToObj(resultPtr, "couldn't readlink \"",
+ Tcl_GetStringFromObj(objv[2], &length), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ linkValue[linkLength] = 0;
+ Tcl_SetStringObj(resultPtr, linkValue, linkLength);
goto done;
}
- linkValue[linkLength] = 0;
- Tcl_SetResult(interp, linkValue, TCL_VOLATILE);
- goto done;
- } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)
- && (length >= 2)) {
- if (argc != 3) {
- argv[1] = "size";
- goto not3Args;
- }
- if (stat(fileName, &statBuf) == -1) {
- goto badStat;
- }
- sprintf(interp->result, "%lu", (unsigned long) statBuf.st_size);
- goto done;
- } else if ((c == 's') && (strncmp(argv[1], "stat", length) == 0)
- && (length >= 2)) {
- if (argc != 4) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " stat name varName\"", (char *) NULL);
- result = TCL_ERROR;
+ case FILE_SIZE:
+ if (objc != 3) {
+ errorString = "size name";
+ goto not3Args;
+ }
+ if (stat(fileName, &statBuf) == -1) {
+ goto badStat;
+ }
+ Tcl_SetLongObj(resultPtr, (long) statBuf.st_size);
goto done;
- }
+ case FILE_STAT:
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "stat name varName");
+ result = TCL_ERROR;
+ goto done;
+ }
- if (stat(fileName, &statBuf) == -1) {
- badStat:
- Tcl_AppendResult(interp, "couldn't stat \"", argv[2],
- "\": ", Tcl_PosixError(interp), (char *) NULL);
- result = TCL_ERROR;
+ if (stat(fileName, &statBuf) == -1) {
+badStat:
+ Tcl_AppendStringsToObj(resultPtr, "couldn't stat \"",
+ Tcl_GetStringFromObj(objv[2], &length),
+ "\": ", Tcl_PosixError(interp), (char *) NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ result = StoreStatData(interp, Tcl_GetStringFromObj(objv[3],
+ &length), &statBuf);
+ goto done;
+ case FILE_TYPE:
+ if (objc != 3) {
+ errorString = "type name";
+ goto not3Args;
+ }
+ if (lstat(fileName, &statBuf) == -1) {
+ goto badStat;
+ }
+ errorString = GetTypeFromMode((int) statBuf.st_mode);
+ Tcl_SetStringObj(resultPtr, errorString, -1);
goto done;
- }
- result = StoreStatData(interp, argv[3], &statBuf);
- goto done;
- } else if ((c == 't') && (strncmp(argv[1], "type", length) == 0)
- && (length >= 2)) {
- if (argc != 3) {
- argv[1] = "type";
- goto not3Args;
- }
- if (lstat(fileName, &statBuf) == -1) {
- goto badStat;
- }
- interp->result = GetTypeFromMode((int) statBuf.st_mode);
- goto done;
- } else {
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": should be atime, dirname, executable, exists, ",
- "extension, isdirectory, isfile, join, ",
- "lstat, mtime, owned, pathtype, readable, readlink, ",
- "root, size, split, stat, tail, type, ",
- "or writable",
- (char *) NULL);
- result = TCL_ERROR;
- goto done;
}
+
if (stat(fileName, &statBuf) == -1) {
- interp->result = "0";
+ Tcl_SetBooleanObj(resultPtr, 0);
goto done;
}
switch (statOp) {
@@ -968,19 +1145,14 @@ Tcl_FileCmd(dummy, interp, argc, argv)
mode = S_ISDIR(statBuf.st_mode);
break;
}
- if (mode) {
- interp->result = "1";
- } else {
- interp->result = "0";
- }
+ Tcl_SetBooleanObj(resultPtr, mode);
- done:
+done:
Tcl_DStringFree(&buffer);
return result;
- not3Args:
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ", argv[1], " name\"", (char *) NULL);
+not3Args:
+ Tcl_WrongNumArgs(interp, 1, objv, errorString);
result = TCL_ERROR;
goto done;
}
@@ -1102,10 +1274,14 @@ GetTypeFromMode(mode)
return "blockSpecial";
} else if (S_ISFIFO(mode)) {
return "fifo";
+#ifdef S_ISLNK
} else if (S_ISLNK(mode)) {
return "link";
+#endif
+#ifdef S_ISSOCK
} else if (S_ISSOCK(mode)) {
return "socket";
+#endif
}
return "unknown";
}
@@ -1115,73 +1291,78 @@ GetTypeFromMode(mode)
*
* Tcl_ForCmd --
*
- * This procedure is invoked to process the "for" Tcl command.
- * See the user documentation for details on what it does.
+ * This procedure is invoked to process the "for" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * With the bytecode compiler, this procedure is only called when
+ * a command name is computed at runtime, and is "for" or the name
+ * to which "for" was renamed: e.g.,
+ * "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}"
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl result.
*
* Side effects:
- * See the user documentation.
+ * See the user documentation.
*
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
+ /* ARGSUSED */
int
Tcl_ForCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
{
int result, value;
if (argc != 5) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " start test next command\"", (char *) NULL);
- return TCL_ERROR;
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " start test next command\"", (char *) NULL);
+ return TCL_ERROR;
}
result = Tcl_Eval(interp, argv[1]);
if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)");
- }
- return result;
+ if (result == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)");
+ }
+ return result;
}
while (1) {
- result = Tcl_ExprBoolean(interp, argv[2], &value);
- if (result != TCL_OK) {
- return result;
- }
- if (!value) {
- break;
- }
- result = Tcl_Eval(interp, argv[4]);
- if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
- if (result == TCL_ERROR) {
- char msg[60];
- sprintf(msg, "\n (\"for\" body line %d)", interp->errorLine);
- Tcl_AddErrorInfo(interp, msg);
- }
- break;
- }
- result = Tcl_Eval(interp, argv[3]);
+ result = Tcl_ExprBoolean(interp, argv[2], &value);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (!value) {
+ break;
+ }
+ result = Tcl_Eval(interp, argv[4]);
+ if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
+ if (result == TCL_ERROR) {
+ char msg[60];
+ sprintf(msg, "\n (\"for\" body line %d)", interp->errorLine);
+ Tcl_AddErrorInfo(interp, msg);
+ }
+ break;
+ }
+ result = Tcl_Eval(interp, argv[3]);
if (result == TCL_BREAK) {
- break;
- } else if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)");
- }
- return result;
- }
+ break;
+ } else if (result != TCL_OK) {
+ if (result == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)");
+ }
+ return result;
+ }
}
if (result == TCL_BREAK) {
- result = TCL_OK;
+ result = TCL_OK;
}
if (result == TCL_OK) {
- Tcl_ResetResult(interp);
+ Tcl_ResetResult(interp);
}
return result;
}
@@ -1189,13 +1370,13 @@ Tcl_ForCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_ForeachCmd --
+ * Tcl_ForeachObjCmd --
*
- * This procedure is invoked to process the "foreach" Tcl command.
- * See the user documentation for details on what it does.
+ * This object-based procedure is invoked to process the "foreach" Tcl
+ * command. See the user documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
* See the user documentation.
@@ -1205,33 +1386,35 @@ Tcl_ForCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_ForeachCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_ForeachObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result = TCL_OK;
int i; /* i selects a value list */
int j, maxj; /* Number of loop iterations */
int v; /* v selects a loop variable */
int numLists; /* Count of value lists */
+ Tcl_Obj *bodyPtr;
+
#define STATIC_SIZE 4
- int indexArray[STATIC_SIZE]; /* Array of value list indices */
- int varcListArray[STATIC_SIZE]; /* Number of loop variables per list */
- char **varvListArray[STATIC_SIZE]; /* Array of variable name lists */
- int argcListArray[STATIC_SIZE]; /* Array of value list sizes */
- char **argvListArray[STATIC_SIZE]; /* Array of value lists */
+ int indexArray[STATIC_SIZE]; /* Array of value list indices */
+ int varcListArray[STATIC_SIZE]; /* # loop variables per list */
+ Tcl_Obj **varvListArray[STATIC_SIZE]; /* Array of variable name lists */
+ int argcListArray[STATIC_SIZE]; /* Array of value list sizes */
+ Tcl_Obj **argvListArray[STATIC_SIZE]; /* Array of value lists */
int *index = indexArray;
int *varcList = varcListArray;
- char ***varvList = varvListArray;
+ Tcl_Obj ***varvList = varvListArray;
int *argcList = argcListArray;
- char ***argvList = argvListArray;
+ Tcl_Obj ***argvList = argvListArray;
- if (argc < 4 || (argc%2 != 0)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " varList list ?varList list ...? command\"", (char *) NULL);
+ if (objc < 4 || (objc%2 != 0)) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "varList list ?varList list ...? command");
return TCL_ERROR;
}
@@ -1243,36 +1426,47 @@ Tcl_ForeachCmd(dummy, interp, argc, argv)
* index[i] is the current pointer into the value list argvList[i]
*/
- numLists = (argc-2)/2;
+ numLists = (objc-2)/2;
if (numLists > STATIC_SIZE) {
index = (int *) ckalloc(numLists * sizeof(int));
varcList = (int *) ckalloc(numLists * sizeof(int));
- varvList = (char ***) ckalloc(numLists * sizeof(char **));
+ varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
argcList = (int *) ckalloc(numLists * sizeof(int));
- argvList = (char ***) ckalloc(numLists * sizeof(char **));
+ argvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
}
- for (i=0 ; i<numLists ; i++) {
+ for (i = 0; i < numLists; i++) {
index[i] = 0;
varcList[i] = 0;
- varvList[i] = (char **)NULL;
+ varvList[i] = (Tcl_Obj **) NULL;
argcList[i] = 0;
- argvList[i] = (char **)NULL;
+ argvList[i] = (Tcl_Obj **) NULL;
}
/*
* Break up the value lists and variable lists into elements
+ * THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE.
*/
maxj = 0;
- for (i=0 ; i<numLists ; i++) {
- result = Tcl_SplitList(interp, argv[1+i*2], &varcList[i], &varvList[i]);
+ for (i = 0; i < numLists; i++) {
+ result = Tcl_ListObjGetElements(interp, objv[1+i*2],
+ &varcList[i], &varvList[i]);
if (result != TCL_OK) {
- goto errorReturn;
+ goto done;
+ }
+ if (varcList[i] < 1) {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "foreach varlist is empty", -1);
+ result = TCL_ERROR;
+ goto done;
}
- result = Tcl_SplitList(interp, argv[2+i*2], &argcList[i], &argvList[i]);
+
+ result = Tcl_ListObjGetElements(interp, objv[2+i*2],
+ &argcList[i], &argvList[i]);
if (result != TCL_OK) {
- goto errorReturn;
+ goto done;
}
+
j = argcList[i] / varcList[i];
if ((argcList[i] % varcList[i]) != 0) {
j++;
@@ -1286,24 +1480,40 @@ Tcl_ForeachCmd(dummy, interp, argc, argv)
* Iterate maxj times through the lists in parallel
* If some value lists run out of values, set loop vars to ""
*/
- for (j = 0; j < maxj; j++) {
- for (i=0 ; i<numLists ; i++) {
- for (v=0 ; v<varcList[i] ; v++) {
+
+ bodyPtr = objv[objc-1];
+ for (j = 0; j < maxj; j++) {
+ for (i = 0; i < numLists; i++) {
+ for (v = 0; v < varcList[i]; v++) {
int k = index[i]++;
- char *value = "";
+ Tcl_Obj *valuePtr, *varValuePtr;
+ int isEmptyObj = 0;
+
if (k < argcList[i]) {
- value = argvList[i][k];
+ valuePtr = argvList[i][k];
+ } else {
+ valuePtr = Tcl_NewObj(); /* empty string */
+ isEmptyObj = 1;
}
- if (Tcl_SetVar(interp, varvList[i][v], value, 0) == NULL) {
- Tcl_AppendResult(interp, "couldn't set loop variable: \"",
- varvList[i][v], "\"", (char *)NULL);
+ varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], NULL,
+ valuePtr, TCL_PARSE_PART1);
+ if (varValuePtr == NULL) {
+ if (isEmptyObj) {
+ Tcl_DecrRefCount(valuePtr);
+ }
+ Tcl_ResetResult(interp);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "couldn't set loop variable: \"",
+ Tcl_GetStringFromObj(varvList[i][v], (int *) NULL),
+ "\"", (char *) NULL);
result = TCL_ERROR;
- goto errorReturn;
+ goto done;
}
+
}
}
- result = Tcl_Eval(interp, argv[argc-1]);
+ result = Tcl_EvalObj(interp, bodyPtr);
if (result != TCL_OK) {
if (result == TCL_CONTINUE) {
result = TCL_OK;
@@ -1314,7 +1524,7 @@ Tcl_ForeachCmd(dummy, interp, argc, argv)
char msg[100];
sprintf(msg, "\n (\"foreach\" body line %d)",
interp->errorLine);
- Tcl_AddErrorInfo(interp, msg);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
break;
} else {
break;
@@ -1324,15 +1534,8 @@ Tcl_ForeachCmd(dummy, interp, argc, argv)
if (result == TCL_OK) {
Tcl_ResetResult(interp);
}
-errorReturn:
- for (i=0 ; i<numLists ; i++) {
- if (argvList[i] != (char **)NULL) {
- ckfree((char *) argvList[i]);
- }
- if (varvList[i] != (char **)NULL) {
- ckfree((char *) varvList[i]);
- }
- }
+
+ done:
if (numLists > STATIC_SIZE) {
ckfree((char *) index);
ckfree((char *) varcList);
@@ -1340,8 +1543,8 @@ errorReturn:
ckfree((char *) varvList);
ckfree((char *) argvList);
}
-#undef STATIC_SIZE
return result;
+#undef STATIC_SIZE
}
/*
@@ -1534,7 +1737,7 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
width = 0;
}
if (width != 0) {
- sprintf(newPtr, "%d", width);
+ TclFormatInt(newPtr, width);
while (*newPtr != 0) {
newPtr++;
}
@@ -1558,7 +1761,7 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
format++;
}
if (precision != 0) {
- sprintf(newPtr, "%d", precision);
+ TclFormatInt(newPtr, precision);
while (*newPtr != 0) {
newPtr++;
}
@@ -1620,12 +1823,18 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
}
break;
case 0:
- interp->result =
- "format string ended in middle of field specifier";
+ Tcl_SetResult(interp,
+ "format string ended in middle of field specifier",
+ TCL_STATIC);
goto fmtError;
default:
- sprintf(interp->result, "bad field specifier \"%c\"", *format);
- goto fmtError;
+ {
+ char buf[80];
+
+ sprintf(buf, "bad field specifier \"%c\"", *format);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ goto fmtError;
+ }
}
argIndex++;
format++;
@@ -1674,11 +1883,10 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
}
}
- interp->result = dst;
if (dstSpace != TCL_RESULT_SIZE) {
- interp->freeProc = TCL_DYNAMIC;
+ Tcl_SetResult(interp, dst, TCL_DYNAMIC);
} else {
- interp->freeProc = 0;
+ Tcl_SetResult(interp, dst, TCL_STATIC);
}
return TCL_OK;
diff --git a/contrib/tcl/generic/tclCmdIL.c b/contrib/tcl/generic/tclCmdIL.c
index 0a3b25a98c81..18342f37ab48 100644
--- a/contrib/tcl/generic/tclCmdIL.c
+++ b/contrib/tcl/generic/tclCmdIL.c
@@ -7,12 +7,13 @@
* (i.e. those that don't depend much upon UNIX facilities).
*
* Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1995 Sun Microsystems, Inc.
+ * Copyright (c) 1993-1997 Lucent Technologies.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCmdIL.c 1.120 96/07/10 17:16:03
+ * SCCS: @(#) tclCmdIL.c 1.163 97/06/13 18:16:52
*/
#include "tclInt.h"
@@ -28,37 +29,126 @@
char *tclExecutableName = NULL;
/*
- * The variables below are used to implement the "lsort" command.
- * Unfortunately, this use of static variables prevents "lsort"
- * from being thread-safe, but there's no alternative given the
- * current implementation of qsort. In a threaded environment
- * these variables should be made thread-local if possible, or else
- * "lsort" needs internal mutual exclusion.
+ * During execution of the "lsort" command, structures of the following
+ * type are used to arrange the objects being sorted into a collection
+ * of linked lists.
*/
-static Tcl_Interp *sortInterp = NULL; /* Interpreter for "lsort" command.
- * NULL means no lsort is active. */
-static enum {ASCII, INTEGER, REAL, COMMAND} sortMode;
- /* Mode for sorting: compare as strings,
- * compare as numbers, or call
- * user-defined command for
- * comparison. */
-static Tcl_DString sortCmd; /* Holds command if mode is COMMAND.
- * pre-initialized to hold base of
- * command. */
-static int sortIncreasing; /* 0 means sort in decreasing order,
- * 1 means increasing order. */
-static int sortCode; /* Anything other than TCL_OK means a
- * problem occurred while sorting; this
- * executing a comparison command, so
- * the sort was aborted. */
+typedef struct SortElement {
+ Tcl_Obj *objPtr; /* Object being sorted. */
+ struct SortElement *nextPtr; /* Next element in the list, or
+ * NULL for end of list. */
+} SortElement;
+
+/*
+ * The "lsort" command needs to pass certain information down to the
+ * function that compares two list elements, and the comparison function
+ * needs to pass success or failure information back up to the top-level
+ * "lsort" command. The following structure is used to pass this
+ * information.
+ */
+
+typedef struct SortInfo {
+ int isIncreasing; /* Nonzero means sort in increasing order. */
+ int sortMode; /* The sort mode. One of SORTMODE_*
+ * values defined below */
+ Tcl_DString compareCmd; /* The Tcl comparison command when sortMode
+ * is SORTMODE_COMMAND. Pre-initialized to
+ * hold base of command.*/
+ long index; /* If the -index option was specified, this
+ * holds the index of the list element
+ * to extract for comparison. If -index
+ * wasn't specified, this is -1. */
+ Tcl_Interp *interp; /* The interpreter in which the sortis
+ * being done. */
+ int resultCode; /* Completion code for the lsort command.
+ * If an error occurs during the sort this
+ * is changed from TCL_OK to TCL_ERROR. */
+} SortInfo;
+
+/*
+ * The "sortMode" field of the SortInfo structure can take on any of the
+ * following values.
+ */
+
+#define SORTMODE_ASCII 0
+#define SORTMODE_INTEGER 1
+#define SORTMODE_REAL 2
+#define SORTMODE_COMMAND 3
+#define SORTMODE_DICTIONARY 4
/*
* Forward declarations for procedures defined in this file:
*/
-static int SortCompareProc _ANSI_ARGS_((CONST VOID *first,
- CONST VOID *second));
+static int DictionaryCompare _ANSI_ARGS_((char *left,
+ char *right));
+static int InfoArgsCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoBodyCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoCommandsCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoCompleteCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoHostnameCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoLevelCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoLibraryCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoLoadedCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoLocalsCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoNameOfExecutableCmd _ANSI_ARGS_((
+ ClientData dummy, Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoProcsCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoScriptCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int InfoVarsCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static SortElement * MergeSort _ANSI_ARGS_((SortElement *headPt,
+ SortInfo *infoPtr));
+static SortElement * MergeLists _ANSI_ARGS_((SortElement *leftPtr,
+ SortElement *rightPtr, SortInfo *infoPtr));
+static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr,
+ Tcl_Obj *second, SortInfo *infoPtr));
/*
*----------------------------------------------------------------------
@@ -68,6 +158,10 @@ static int SortCompareProc _ANSI_ARGS_((CONST VOID *first,
* This procedure is invoked to process the "if" Tcl command.
* See the user documentation for details on what it does.
*
+ * With the bytecode compiler, this procedure is only called when
+ * a command name is computed at runtime, and is "if" or the name
+ * to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}"
+ *
* Results:
* A standard Tcl result.
*
@@ -118,7 +212,7 @@ Tcl_IfCmd(dummy, interp, argc, argv)
if (value) {
return Tcl_Eval(interp, argv[i]);
}
-
+
/*
* The expression evaluated to false. Skip the command, then
* see if there is an "else" or "elseif" clause.
@@ -161,6 +255,10 @@ Tcl_IfCmd(dummy, interp, argc, argv)
* This procedure is invoked to process the "incr" Tcl command.
* See the user documentation for details on what it does.
*
+ * With the bytecode compiler, this procedure is only called when
+ * a command name is computed at runtime, and is "incr" or the name
+ * to which "incr" was renamed: e.g., "set z incr; $z i -1"
+ *
* Results:
* A standard Tcl result.
*
@@ -209,19 +307,24 @@ Tcl_IncrCmd(dummy, interp, argc, argv)
}
value += increment;
}
- sprintf(newString, "%d", value);
+ TclFormatInt(newString, value);
result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
if (result == NULL) {
return TCL_ERROR;
}
- interp->result = result;
+
+ /*
+ * Copy the result since the variable's value might change.
+ */
+
+ Tcl_SetResult(interp, result, TCL_VOLATILE);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_InfoCmd --
+ * Tcl_InfoObjCmd --
*
* This procedure is invoked to process the "info" Tcl command.
* See the user documentation for details on what it does.
@@ -237,434 +340,1394 @@ Tcl_IncrCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_InfoCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_InfoObjCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Arbitrary value passed to the command. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ static char *subCmds[] = {
+ "args", "body", "cmdcount", "commands",
+ "complete", "default", "exists", "globals",
+ "hostname", "level", "library", "loaded",
+ "locals", "nameofexecutable", "patchlevel", "procs",
+ "script", "sharedlibextension", "tclversion", "vars",
+ (char *) NULL};
+ enum ISubCmdIdx {
+ IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
+ ICompleteIdx, IDefaultIdx, IExistsIdx, IGlobalsIdx,
+ IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
+ ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
+ IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
+ } index;
+ int result;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
+ return TCL_ERROR;
+ }
+
+ result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
+ (int *) &index);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ switch (index) {
+ case IArgsIdx:
+ result = InfoArgsCmd(clientData, interp, objc, objv);
+ break;
+ case IBodyIdx:
+ result = InfoBodyCmd(clientData, interp, objc, objv);
+ break;
+ case ICmdCountIdx:
+ result = InfoCmdCountCmd(clientData, interp, objc, objv);
+ break;
+ case ICommandsIdx:
+ result = InfoCommandsCmd(clientData, interp, objc, objv);
+ break;
+ case ICompleteIdx:
+ result = InfoCompleteCmd(clientData, interp, objc, objv);
+ break;
+ case IDefaultIdx:
+ result = InfoDefaultCmd(clientData, interp, objc, objv);
+ break;
+ case IExistsIdx:
+ result = InfoExistsCmd(clientData, interp, objc, objv);
+ break;
+ case IGlobalsIdx:
+ result = InfoGlobalsCmd(clientData, interp, objc, objv);
+ break;
+ case IHostnameIdx:
+ result = InfoHostnameCmd(clientData, interp, objc, objv);
+ break;
+ case ILevelIdx:
+ result = InfoLevelCmd(clientData, interp, objc, objv);
+ break;
+ case ILibraryIdx:
+ result = InfoLibraryCmd(clientData, interp, objc, objv);
+ break;
+ case ILoadedIdx:
+ result = InfoLoadedCmd(clientData, interp, objc, objv);
+ break;
+ case ILocalsIdx:
+ result = InfoLocalsCmd(clientData, interp, objc, objv);
+ break;
+ case INameOfExecutableIdx:
+ result = InfoNameOfExecutableCmd(clientData, interp, objc, objv);
+ break;
+ case IPatchLevelIdx:
+ result = InfoPatchLevelCmd(clientData, interp, objc, objv);
+ break;
+ case IProcsIdx:
+ result = InfoProcsCmd(clientData, interp, objc, objv);
+ break;
+ case IScriptIdx:
+ result = InfoScriptCmd(clientData, interp, objc, objv);
+ break;
+ case ISharedLibExtensionIdx:
+ result = InfoSharedlibCmd(clientData, interp, objc, objv);
+ break;
+ case ITclVersionIdx:
+ result = InfoTclVersionCmd(clientData, interp, objc, objv);
+ break;
+ case IVarsIdx:
+ result = InfoVarsCmd(clientData, interp, objc, objv);
+ break;
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoArgsCmd --
+ *
+ * Called to implement the "info args" command that returns the
+ * argument list for a procedure. Handles the following syntax:
+ *
+ * info args procName
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoArgsCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
- size_t length;
- int c;
- Arg *argPtr;
+ char *name;
Proc *procPtr;
- Var *varPtr;
- Command *cmdPtr;
- Tcl_HashEntry *hPtr;
- Tcl_HashSearch search;
+ CompiledLocal *localPtr;
+ Tcl_Obj *listObjPtr;
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option ?arg arg ...?\"", (char *) NULL);
- return TCL_ERROR;
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "args procname");
+ return TCL_ERROR;
}
- c = argv[1][0];
- length = strlen(argv[1]);
- if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " args procname\"", (char *) NULL);
- return TCL_ERROR;
- }
- procPtr = TclFindProc(iPtr, argv[2]);
- if (procPtr == NULL) {
- infoNoSuchProc:
- Tcl_AppendResult(interp, "\"", argv[2],
- "\" isn't a procedure", (char *) NULL);
- return TCL_ERROR;
- }
- for (argPtr = procPtr->argPtr; argPtr != NULL;
- argPtr = argPtr->nextPtr) {
- Tcl_AppendElement(interp, argPtr->name);
- }
- return TCL_OK;
- } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " body procname\"", (char *) NULL);
- return TCL_ERROR;
- }
- procPtr = TclFindProc(iPtr, argv[2]);
- if (procPtr == NULL) {
- goto infoNoSuchProc;
- }
- iPtr->result = procPtr->command;
- return TCL_OK;
- } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0)
- && (length >= 2)) {
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " cmdcount\"", (char *) NULL);
- return TCL_ERROR;
- }
- sprintf(iPtr->result, "%d", iPtr->cmdCount);
- return TCL_OK;
- } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0)
- && (length >= 4)) {
- if (argc > 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " commands ?pattern?\"", (char *) NULL);
- return TCL_ERROR;
- }
- for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
- hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
- char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
- if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
- continue;
- }
- Tcl_AppendElement(interp, name);
- }
- return TCL_OK;
- } else if ((c == 'c') && (strncmp(argv[1], "complete", length) == 0)
- && (length >= 4)) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " complete command\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (Tcl_CommandComplete(argv[2])) {
- interp->result = "1";
- } else {
- interp->result = "0";
- }
- return TCL_OK;
- } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {
- if (argc != 5) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " default procname arg varname\"",
- (char *) NULL);
+
+ name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ procPtr = TclFindProc(iPtr, name);
+ if (procPtr == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "\"", name, "\" isn't a procedure", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Build a return list containing the arguments.
+ */
+
+ listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
+ localPtr = localPtr->nextPtr) {
+ if (localPtr->isArg) {
+ Tcl_ListObjAppendElement(interp, listObjPtr,
+ Tcl_NewStringObj(localPtr->name, -1));
+ }
+ }
+ Tcl_SetObjResult(interp, listObjPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoBodyCmd --
+ *
+ * Called to implement the "info body" command that returns the body
+ * for a procedure. Handles the following syntax:
+ *
+ * info body procName
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoBodyCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ register Interp *iPtr = (Interp *) interp;
+ char *name;
+ Proc *procPtr;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "body procname");
+ return TCL_ERROR;
+ }
+
+ name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ procPtr = TclFindProc(iPtr, name);
+ if (procPtr == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "\"", name, "\" isn't a procedure", (char *) NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, procPtr->bodyPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoCmdCountCmd --
+ *
+ * Called to implement the "info cmdcount" command that returns the
+ * number of commands that have been executed. Handles the following
+ * syntax:
+ *
+ * info cmdcount
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoCmdCountCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ Interp *iPtr = (Interp *) interp;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "cmdcount");
+ return TCL_ERROR;
+ }
+
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoCommandsCmd --
+ *
+ * Called to implement the "info commands" command that returns the
+ * list of commands in the interpreter that match an optional pattern.
+ * The pattern, if any, consists of an optional sequence of namespace
+ * names separated by "::" qualifiers, which is followed by a
+ * glob-style pattern that restricts which commands are returned.
+ * Handles the following syntax:
+ *
+ * info commands ?pattern?
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoCommandsCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ char *cmdName, *pattern, *simplePattern;
+ register Tcl_HashEntry *entryPtr;
+ Tcl_HashSearch search;
+ Namespace *nsPtr;
+ Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
+ Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+ Tcl_Obj *listPtr, *elemObjPtr;
+ int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
+ Tcl_Command cmd;
+ int result;
+
+ /*
+ * Get the pattern and find the "effective namespace" in which to
+ * list commands.
+ */
+
+ if (objc == 2) {
+ simplePattern = NULL;
+ nsPtr = currNsPtr;
+ specificNsInPattern = 0;
+ } else if (objc == 3) {
+ /*
+ * From the pattern, get the effective namespace and the simple
+ * pattern (no namespace qualifiers or ::'s) at the end. If an
+ * error was found while parsing the pattern, return it. Otherwise,
+ * if the namespace wasn't found, just leave nsPtr NULL: we will
+ * return an empty list since no commands there can be found.
+ */
+
+ Namespace *dummy1NsPtr, *dummy2NsPtr;
+
+ pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ result = TclGetNamespaceForQualName(interp, pattern,
+ (Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG,
+ &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
+ if (result != TCL_OK) {
return TCL_ERROR;
}
- procPtr = TclFindProc(iPtr, argv[2]);
- if (procPtr == NULL) {
- goto infoNoSuchProc;
+ if (nsPtr != NULL) { /* we successfully found the pattern's ns */
+ specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
}
- for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) {
- if (argPtr == NULL) {
- Tcl_AppendResult(interp, "procedure \"", argv[2],
- "\" doesn't have an argument \"", argv[3],
- "\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (strcmp(argv[3], argPtr->name) == 0) {
- if (argPtr->defValue != NULL) {
- if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4],
- argPtr->defValue, 0) == NULL) {
- defStoreError:
- Tcl_AppendResult(interp,
- "couldn't store default value in variable \"",
- argv[4], "\"", (char *) NULL);
- return TCL_ERROR;
- }
- iPtr->result = "1";
+ } else {
+ Tcl_WrongNumArgs(interp, 1, objv, "commands ?pattern?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Scan through the effective namespace's command table and create a
+ * list with all commands that match the pattern. If a specific
+ * namespace was requested in the pattern, qualify the command names
+ * with the namespace name.
+ */
+
+ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+
+ if (nsPtr != NULL) {
+ entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
+ while (entryPtr != NULL) {
+ cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
+ if ((simplePattern == NULL)
+ || Tcl_StringMatch(cmdName, simplePattern)) {
+ if (specificNsInPattern) {
+ cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
+ elemObjPtr = Tcl_NewObj();
+ Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
} else {
- if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0)
- == NULL) {
- goto defStoreError;
- }
- iPtr->result = "0";
+ elemObjPtr = Tcl_NewStringObj(cmdName, -1);
}
- return TCL_OK;
+ Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
+ entryPtr = Tcl_NextHashEntry(&search);
}
- } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {
- char *p;
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " exists varName\"", (char *) NULL);
- return TCL_ERROR;
- }
- p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0);
/*
- * The code below handles the special case where the name is for
- * an array: Tcl_GetVar will reject this since you can't read
- * an array variable without an index.
+ * If the effective namespace isn't the global :: namespace, and a
+ * specific namespace wasn't requested in the pattern, then add in
+ * all global :: commands that match the simple pattern. Of course,
+ * we add in only those commands that aren't hidden by a command in
+ * the effective namespace.
*/
-
- if (p == NULL) {
- Tcl_HashEntry *hPtr;
- Var *varPtr;
-
- if (strchr(argv[2], '(') != NULL) {
- noVar:
- iPtr->result = "0";
- return TCL_OK;
- }
- if (iPtr->varFramePtr == NULL) {
- hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
- } else {
- hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
- }
- if (hPtr == NULL) {
- goto noVar;
- }
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
- if (varPtr->flags & VAR_UPVAR) {
- varPtr = varPtr->value.upvarPtr;
- }
- if (!(varPtr->flags & VAR_ARRAY)) {
- goto noVar;
+
+ if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
+ entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
+ while (entryPtr != NULL) {
+ cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
+ if ((simplePattern == NULL)
+ || Tcl_StringMatch(cmdName, simplePattern)) {
+ if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(cmdName, -1));
+ }
+ }
+ entryPtr = Tcl_NextHashEntry(&search);
}
}
- iPtr->result = "1";
- return TCL_OK;
- } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {
- char *name;
+ }
+
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoCompleteCmd --
+ *
+ * Called to implement the "info complete" command that determines
+ * whether a string is a complete Tcl command. Handles the following
+ * syntax:
+ *
+ * info complete command
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
- if (argc > 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " globals ?pattern?\"", (char *) NULL);
- return TCL_ERROR;
- }
- for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search);
- hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
- if (varPtr->flags & VAR_UNDEFINED) {
- continue;
- }
- name = Tcl_GetHashKey(&iPtr->globalTable, hPtr);
- if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
- continue;
- }
- Tcl_AppendElement(interp, name);
- }
- return TCL_OK;
- } else if ((c == 'h') && (strncmp(argv[1], "hostname", length) == 0)) {
- if (argc > 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " hostname\"", (char *) NULL);
- return TCL_ERROR;
- }
- Tcl_AppendResult(interp, Tcl_GetHostName(), NULL);
+static int
+InfoCompleteCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ char *command;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "complete command");
+ return TCL_ERROR;
+ }
+
+ command = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ if (Tcl_CommandComplete(command)) {
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
+ } else {
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoDefaultCmd --
+ *
+ * Called to implement the "info default" command that returns the
+ * default value for a procedure argument. Handles the following
+ * syntax:
+ *
+ * info default procName arg varName
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoDefaultCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ Interp *iPtr = (Interp *) interp;
+ char *procName, *argName, *varName;
+ Proc *procPtr;
+ CompiledLocal *localPtr;
+ Tcl_Obj *valueObjPtr;
+
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 1, objv, "default procname arg varname");
+ return TCL_ERROR;
+ }
+
+ procName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ argName = Tcl_GetStringFromObj(objv[3], (int *) NULL);
+
+ procPtr = TclFindProc(iPtr, procName);
+ if (procPtr == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "\"", procName, "\" isn't a procedure", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
+ localPtr = localPtr->nextPtr) {
+ if ((localPtr->isArg) && (strcmp(argName, localPtr->name) == 0)) {
+ if (localPtr->defValuePtr != NULL) {
+ valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
+ localPtr->defValuePtr, 0);
+ if (valueObjPtr == NULL) {
+ defStoreError:
+ varName = Tcl_GetStringFromObj(objv[4], (int *) NULL);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "couldn't store default value in variable \"",
+ varName, "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
+ } else {
+ Tcl_Obj *nullObjPtr = Tcl_NewObj();
+ valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
+ nullObjPtr, 0);
+ if (valueObjPtr == NULL) {
+ Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */
+ goto defStoreError;
+ }
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
+ }
+ return TCL_OK;
+ }
+ }
+
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "procedure \"", procName, "\" doesn't have an argument \"",
+ argName, "\"", (char *) NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoExistsCmd --
+ *
+ * Called to implement the "info exists" command that determines
+ * whether a variable exists. Handles the following syntax:
+ *
+ * info exists varName
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoExistsCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ char *varName;
+ Var *varPtr, *arrayPtr;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "exists varName");
+ return TCL_ERROR;
+ }
+
+ varName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ varPtr = TclLookupVar(interp, varName, (char *) NULL,
+ TCL_PARSE_PART1, "access",
+ /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+ if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) {
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
+ } else {
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoGlobalsCmd --
+ *
+ * Called to implement the "info globals" command that returns the list
+ * of global variables matching an optional pattern. Handles the
+ * following syntax:
+ *
+ * info globals ?pattern?
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoGlobalsCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ char *varName, *pattern;
+ Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
+ register Tcl_HashEntry *entryPtr;
+ Tcl_HashSearch search;
+ Var *varPtr;
+ Tcl_Obj *listPtr;
+
+ if (objc == 2) {
+ pattern = NULL;
+ } else if (objc == 3) {
+ pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ } else {
+ Tcl_WrongNumArgs(interp, 1, objv, "globals ?pattern?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Scan through the global :: namespace's variable table and create a
+ * list of all global variables that match the pattern.
+ */
+
+ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
+ entryPtr != NULL;
+ entryPtr = Tcl_NextHashEntry(&search)) {
+ varPtr = (Var *) Tcl_GetHashValue(entryPtr);
+ if (TclIsVarUndefined(varPtr)) {
+ continue;
+ }
+ varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr);
+ if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(varName, -1));
+ }
+ }
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoHostnameCmd --
+ *
+ * Called to implement the "info hostname" command that returns the
+ * host name. Handles the following syntax:
+ *
+ * info hostname
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoHostnameCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "hostname");
+ return TCL_ERROR;
+ }
+
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), Tcl_GetHostName(), -1);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoLevelCmd --
+ *
+ * Called to implement the "info level" command that returns
+ * information about the call stack. Handles the following syntax:
+ *
+ * info level ?number?
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoLevelCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ Interp *iPtr = (Interp *) interp;
+ int level;
+ CallFrame *framePtr;
+ Tcl_Obj *listPtr;
+
+ if (objc == 2) { /* just "info level" */
+ if (iPtr->varFramePtr == NULL) {
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
+ } else {
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level);
+ }
return TCL_OK;
- } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0)
- && (length >= 2)) {
- if (argc == 2) {
- if (iPtr->varFramePtr == NULL) {
- iPtr->result = "0";
- } else {
- sprintf(iPtr->result, "%d", iPtr->varFramePtr->level);
- }
- return TCL_OK;
- } else if (argc == 3) {
- int level;
- CallFrame *framePtr;
+ } else if (objc == 3) {
+ if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (level <= 0) {
+ if (iPtr->varFramePtr == NULL) {
+ levelError:
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "bad level \"",
+ Tcl_GetStringFromObj(objv[2], (int *) NULL),
+ "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ level += iPtr->varFramePtr->level;
+ }
+ for (framePtr = iPtr->varFramePtr; framePtr != NULL;
+ framePtr = framePtr->callerVarPtr) {
+ if (framePtr->level == level) {
+ break;
+ }
+ }
+ if (framePtr == NULL) {
+ goto levelError;
+ }
+
+ listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+ }
- if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) {
- return TCL_ERROR;
- }
- if (level <= 0) {
- if (iPtr->varFramePtr == NULL) {
- levelError:
- Tcl_AppendResult(interp, "bad level \"", argv[2],
- "\"", (char *) NULL);
- return TCL_ERROR;
- }
- level += iPtr->varFramePtr->level;
+ Tcl_WrongNumArgs(interp, 1, objv, "level ?number?");
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoLibraryCmd --
+ *
+ * Called to implement the "info library" command that returns the
+ * library directory for the Tcl installation. Handles the following
+ * syntax:
+ *
+ * info library
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoLibraryCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ char *libDirName;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "library");
+ return TCL_ERROR;
+ }
+
+ libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
+ if (libDirName != NULL) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1);
+ return TCL_OK;
+ }
+ Tcl_SetStringObj(Tcl_GetObjResult(interp),
+ "no library has been specified for Tcl", -1);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoLoadedCmd --
+ *
+ * Called to implement the "info loaded" command that returns the
+ * packages that have been loaded into an interpreter. Handles the
+ * following syntax:
+ *
+ * info loaded ?interp?
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoLoadedCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ char *interpName;
+ int result;
+
+ if ((objc != 2) && (objc != 3)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "loaded ?interp?");
+ return TCL_ERROR;
+ }
+
+ if (objc == 2) { /* get loaded pkgs in all interpreters */
+ interpName = NULL;
+ } else { /* get pkgs just in specified interp */
+ interpName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ }
+ result = TclGetLoadedPackages(interp, interpName);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoLocalsCmd --
+ *
+ * Called to implement the "info locals" command to return a list of
+ * local variables that match an optional pattern. Handles the
+ * following syntax:
+ *
+ * info locals ?pattern?
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoLocalsCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Var *varPtr;
+ char *varName, *pattern;
+ int i, localVarCt;
+ Tcl_HashTable *localVarTablePtr;
+ register Tcl_HashEntry *entryPtr;
+ Tcl_HashSearch search;
+ Tcl_Obj *listPtr;
+
+ if (objc == 2) {
+ pattern = NULL;
+ } else if (objc == 3) {
+ pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ } else {
+ Tcl_WrongNumArgs(interp, 1, objv, "locals ?pattern?");
+ return TCL_ERROR;
+ }
+
+ if (iPtr->varFramePtr == NULL) {
+ return TCL_OK;
+ }
+ localVarTablePtr = iPtr->varFramePtr->varTablePtr;
+
+ /*
+ * Return a list containing names of first the compiled locals (i.e. the
+ * ones stored in the call frame), then the variables in the local hash
+ * table (if one exists).
+ */
+
+ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+
+ localVarCt = iPtr->varFramePtr->numCompiledLocals;
+ for (i = 0, varPtr = iPtr->varFramePtr->compiledLocals;
+ i < localVarCt;
+ i++, varPtr++) {
+ if (!TclIsVarUndefined(varPtr)) {
+ varName = varPtr->name;
+ if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(varName, -1));
}
- for (framePtr = iPtr->varFramePtr; framePtr != NULL;
- framePtr = framePtr->callerVarPtr) {
- if (framePtr->level == level) {
- break;
+ }
+ }
+
+ if (localVarTablePtr != NULL) {
+ for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search);
+ entryPtr != NULL;
+ entryPtr = Tcl_NextHashEntry(&search)) {
+ varPtr = (Var *) Tcl_GetHashValue(entryPtr);
+ if (!TclIsVarUndefined(varPtr) && !TclIsVarLink(varPtr)) {
+ varName = Tcl_GetHashKey(localVarTablePtr, entryPtr);
+ if ((pattern == NULL)
+ || Tcl_StringMatch(varName, pattern)) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(varName, -1));
}
}
- if (framePtr == NULL) {
- goto levelError;
- }
- iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv);
- iPtr->freeProc = TCL_DYNAMIC;
- return TCL_OK;
}
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " level [number]\"", (char *) NULL);
- return TCL_ERROR;
- } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0)
- && (length >= 2)) {
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " library\"", (char *) NULL);
+ }
+
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoNameOfExecutableCmd --
+ *
+ * Called to implement the "info nameofexecutable" command that returns
+ * the name of the binary file running this application. Handles the
+ * following syntax:
+ *
+ * info nameofexecutable
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoNameOfExecutableCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "nameofexecutable");
+ return TCL_ERROR;
+ }
+
+ if (tclExecutableName != NULL) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), tclExecutableName, -1);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoPatchLevelCmd --
+ *
+ * Called to implement the "info patchlevel" command that returns the
+ * default value for an argument to a procedure. Handles the following
+ * syntax:
+ *
+ * info patchlevel
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoPatchLevelCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ char *patchlevel;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "patchlevel");
+ return TCL_ERROR;
+ }
+
+ patchlevel = Tcl_GetVar(interp, "tcl_patchLevel",
+ (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
+ if (patchlevel != NULL) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1);
+ return TCL_OK;
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoProcsCmd --
+ *
+ * Called to implement the "info procs" command that returns the
+ * procedures in the current namespace that match an optional pattern.
+ * Handles the following syntax:
+ *
+ * info procs ?pattern?
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoProcsCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ char *cmdName, *pattern;
+ Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+ register Tcl_HashEntry *entryPtr;
+ Tcl_HashSearch search;
+ Command *cmdPtr;
+ Tcl_Obj *listPtr;
+
+ if (objc == 2) {
+ pattern = NULL;
+ } else if (objc == 3) {
+ pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ } else {
+ Tcl_WrongNumArgs(interp, 1, objv, "procs ?pattern?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Scan through the current namespace's command table and return a list
+ * of all procs that match the pattern.
+ */
+
+ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ for (entryPtr = Tcl_FirstHashEntry(&currNsPtr->cmdTable, &search);
+ entryPtr != NULL;
+ entryPtr = Tcl_NextHashEntry(&search)) {
+ cmdName = Tcl_GetHashKey(&currNsPtr->cmdTable, entryPtr);
+ cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+ if (TclIsProc(cmdPtr)) {
+ if ((pattern == NULL) || Tcl_StringMatch(cmdName, pattern)) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(cmdName, -1));
+ }
+ }
+ }
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoScriptCmd --
+ *
+ * Called to implement the "info script" command that returns the
+ * script file that is currently being evaluated. Handles the
+ * following syntax:
+ *
+ * info script
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoScriptCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ Interp *iPtr = (Interp *) interp;
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "script");
+ return TCL_ERROR;
+ }
+
+ if (iPtr->scriptFile != NULL) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), iPtr->scriptFile, -1);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoSharedlibCmd --
+ *
+ * Called to implement the "info sharedlibextension" command that
+ * returns the file extension used for shared libraries. Handles the
+ * following syntax:
+ *
+ * info sharedlibextension
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoSharedlibCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "sharedlibextension");
+ return TCL_ERROR;
+ }
+
+#ifdef TCL_SHLIB_EXT
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1);
+#endif
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoTclVersionCmd --
+ *
+ * Called to implement the "info tclversion" command that returns the
+ * version number for this Tcl library. Handles the following syntax:
+ *
+ * info tclversion
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoTclVersionCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ char *version;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "tclversion");
+ return TCL_ERROR;
+ }
+
+ version = Tcl_GetVar(interp, "tcl_version",
+ (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
+ if (version != NULL) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1);
+ return TCL_OK;
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InfoVarsCmd --
+ *
+ * Called to implement the "info vars" command that returns the
+ * list of variables in the interpreter that match an optional pattern.
+ * The pattern, if any, consists of an optional sequence of namespace
+ * names separated by "::" qualifiers, which is followed by a
+ * glob-style pattern that restricts which variables are returned.
+ * Handles the following syntax:
+ *
+ * info vars ?pattern?
+ *
+ * Results:
+ * Returns TCL_OK is successful and TCL_ERROR is there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoVarsCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ Interp *iPtr = (Interp *) interp;
+ char *varName, *pattern, *simplePattern;
+ register Tcl_HashEntry *entryPtr;
+ Tcl_HashSearch search;
+ Var *varPtr, *localVarPtr;
+ Namespace *nsPtr;
+ Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
+ Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+ Tcl_Obj *listPtr, *elemObjPtr;
+ int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
+ int i, result;
+
+ /*
+ * Get the pattern and find the "effective namespace" in which to
+ * list variables. We only use this effective namespace if there's
+ * no active Tcl procedure frame.
+ */
+
+ if (objc == 2) {
+ simplePattern = NULL;
+ nsPtr = currNsPtr;
+ specificNsInPattern = 0;
+ } else if (objc == 3) {
+ /*
+ * From the pattern, get the effective namespace and the simple
+ * pattern (no namespace qualifiers or ::'s) at the end. If an
+ * error was found while parsing the pattern, return it. Otherwise,
+ * if the namespace wasn't found, just leave nsPtr NULL: we will
+ * return an empty list since no variables there can be found.
+ */
+
+ Namespace *dummy1NsPtr, *dummy2NsPtr;
+
+ pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ result = TclGetNamespaceForQualName(interp, pattern,
+ (Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG,
+ &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
+ if (result != TCL_OK) {
return TCL_ERROR;
}
- interp->result = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
- if (interp->result == NULL) {
- interp->result = "no library has been specified for Tcl";
- return TCL_ERROR;
+ if (nsPtr != NULL) { /* we successfully found the pattern's ns */
+ specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
}
+ } else {
+ Tcl_WrongNumArgs(interp, 1, objv, "vars ?pattern?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * If the namespace specified in the pattern wasn't found, just return.
+ */
+
+ if (nsPtr == NULL) {
return TCL_OK;
- } else if ((c == 'l') && (strncmp(argv[1], "loaded", length) == 0)
- && (length >= 3)) {
- if ((argc != 2) && (argc != 3)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " loaded ?interp?\"", (char *) NULL);
- return TCL_ERROR;
- }
- return TclGetLoadedPackages(interp, argv[2]);
- } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
- && (length >= 3)) {
- char *name;
-
- if (argc > 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " locals ?pattern?\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (iPtr->varFramePtr == NULL) {
- return TCL_OK;
- }
- for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search);
- hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
- if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) {
- continue;
- }
- name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr);
- if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
- continue;
+ }
+
+ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+
+ if ((iPtr->varFramePtr == NULL)
+ || !iPtr->varFramePtr->isProcCallFrame
+ || specificNsInPattern) {
+ /*
+ * There is no frame pointer, the frame pointer was pushed only
+ * to activate a namespace, or we are in a procedure call frame
+ * but a specific namespace was specified. Create a list containing
+ * only the variables in the effective namespace's variable table.
+ */
+
+ entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
+ while (entryPtr != NULL) {
+ varPtr = (Var *) Tcl_GetHashValue(entryPtr);
+ if (!TclIsVarUndefined(varPtr)) {
+ varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
+ if ((simplePattern == NULL)
+ || Tcl_StringMatch(varName, simplePattern)) {
+ if (specificNsInPattern) {
+ elemObjPtr = Tcl_NewObj();
+ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
+ elemObjPtr);
+ } else {
+ elemObjPtr = Tcl_NewStringObj(varName, -1);
+ }
+ Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
+ }
}
- Tcl_AppendElement(interp, name);
+ entryPtr = Tcl_NextHashEntry(&search);
}
- return TCL_OK;
- } else if ((c == 'n') && (strncmp(argv[1], "nameofexecutable",
- length) == 0)) {
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " nameofexecutable\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (tclExecutableName != NULL) {
- interp->result = tclExecutableName;
- }
- return TCL_OK;
- } else if ((c == 'p') && (strncmp(argv[1], "patchlevel", length) == 0)
- && (length >= 2)) {
- char *value;
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " patchlevel\"", (char *) NULL);
- return TCL_ERROR;
- }
- value = Tcl_GetVar(interp, "tcl_patchLevel",
- TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
- if (value == NULL) {
- return TCL_ERROR;
- }
- interp->result = value;
- return TCL_OK;
- } else if ((c == 'p') && (strncmp(argv[1], "procs", length) == 0)
- && (length >= 2)) {
- if (argc > 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " procs ?pattern?\"", (char *) NULL);
- return TCL_ERROR;
- }
- for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
- hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
- char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
+ /*
+ * If the effective namespace isn't the global :: namespace, and a
+ * specific namespace wasn't requested in the pattern (i.e., the
+ * pattern only specifies variable names), then add in all global ::
+ * variables that match the simple pattern. Of course, add in only
+ * those variables that aren't hidden by a variable in the effective
+ * namespace.
+ */
- cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
- if (!TclIsProc(cmdPtr)) {
- continue;
- }
- if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
- continue;
+ if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
+ entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
+ while (entryPtr != NULL) {
+ varPtr = (Var *) Tcl_GetHashValue(entryPtr);
+ if (!TclIsVarUndefined(varPtr)) {
+ varName = Tcl_GetHashKey(&globalNsPtr->varTable,
+ entryPtr);
+ if ((simplePattern == NULL)
+ || Tcl_StringMatch(varName, simplePattern)) {
+ if (Tcl_FindHashEntry(&nsPtr->varTable, varName) == NULL) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(varName, -1));
+ }
+ }
+ }
+ entryPtr = Tcl_NextHashEntry(&search);
}
- Tcl_AppendElement(interp, name);
- }
- return TCL_OK;
- } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)
- && (length >= 2)) {
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " script\"", (char *) NULL);
- return TCL_ERROR;
}
- if (iPtr->scriptFile != NULL) {
- /*
- * Can't depend on iPtr->scriptFile to be non-volatile:
- * if this command is returned as the result of the script,
- * then iPtr->scriptFile will go away.
- */
+ } else {
+ /*
+ * We're in a local call frame and no specific namespace was
+ * specific. Create a list that starts with the compiled locals
+ * (i.e. the ones stored in the call frame).
+ */
- Tcl_SetResult(interp, iPtr->scriptFile, TCL_VOLATILE);
- }
- return TCL_OK;
- } else if ((c == 's') && (strncmp(argv[1], "sharedlibextension",
- length) == 0) && (length >= 2)) {
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " sharedlibextension\"", (char *) NULL);
- return TCL_ERROR;
- }
-#ifdef TCL_SHLIB_EXT
- interp->result = TCL_SHLIB_EXT;
-#endif
- return TCL_OK;
- } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {
- char *value;
+ CallFrame *varFramePtr = iPtr->varFramePtr;
+ int localVarCt = varFramePtr->numCompiledLocals;
+ Tcl_HashTable *varTablePtr = varFramePtr->varTablePtr;
+
+ for (i = 0, localVarPtr = iPtr->varFramePtr->compiledLocals;
+ i < localVarCt;
+ i++, localVarPtr++) {
+ if (!TclIsVarUndefined(localVarPtr)) {
+ varName = localVarPtr->name;
+ if ((simplePattern == NULL)
+ || Tcl_StringMatch(varName, simplePattern)) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(varName, -1));
+ }
+ }
+ }
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " tclversion\"", (char *) NULL);
- return TCL_ERROR;
- }
- value = Tcl_GetVar(interp, "tcl_version",
- TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
- if (value == NULL) {
- return TCL_ERROR;
- }
- interp->result = value;
- return TCL_OK;
- } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) {
- Tcl_HashTable *tablePtr;
- char *name;
+ /*
+ * Now add in the variables in the call frame's variable hash
+ * table (if one exists).
+ */
- if (argc > 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " vars ?pattern?\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (iPtr->varFramePtr == NULL) {
- tablePtr = &iPtr->globalTable;
- } else {
- tablePtr = &iPtr->varFramePtr->varTable;
- }
- for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);
- hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
- if (varPtr->flags & VAR_UNDEFINED) {
- continue;
- }
- name = Tcl_GetHashKey(tablePtr, hPtr);
- if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
- continue;
+ if (varTablePtr != NULL) {
+ for (entryPtr = Tcl_FirstHashEntry(varTablePtr, &search);
+ entryPtr != NULL;
+ entryPtr = Tcl_NextHashEntry(&search)) {
+ varPtr = (Var *) Tcl_GetHashValue(entryPtr);
+ if (!TclIsVarUndefined(varPtr)) {
+ varName = Tcl_GetHashKey(varTablePtr, entryPtr);
+ if ((simplePattern == NULL)
+ || Tcl_StringMatch(varName, simplePattern)) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(varName, -1));
+ }
+ }
}
- Tcl_AppendElement(interp, name);
}
- return TCL_OK;
- } else {
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": should be args, body, cmdcount, commands, ",
- "complete, default, ",
- "exists, globals, hostname, level, library, loaded, locals, ",
- "nameofexecutable, patchlevel, procs, script, ",
- "sharedlibextension, tclversion, or vars",
- (char *) NULL);
- return TCL_ERROR;
}
+
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_JoinCmd --
+ * Tcl_JoinObjCmd --
*
* This procedure is invoked to process the "join" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
* See the user documentation.
@@ -674,50 +1737,63 @@ Tcl_InfoCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_JoinCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_JoinObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* The argument objects. */
{
- char *joinString;
- char **listArgv;
- int listArgc, i;
+ char *joinString, *bytes;
+ int joinLength, listLen, length, i, result;
+ Tcl_Obj **elemPtrs;
- if (argc == 2) {
+ if (objc == 2) {
joinString = " ";
- } else if (argc == 3) {
- joinString = argv[2];
+ joinLength = 1;
+ } else if (objc == 3) {
+ joinString = Tcl_GetStringFromObj(objv[2], &joinLength);
} else {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " list ?joinString?\"", (char *) NULL);
+ Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
return TCL_ERROR;
}
- if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
- return TCL_ERROR;
+ /*
+ * Make sure the list argument is a list object and get its length and
+ * a pointer to its array of element pointers.
+ */
+
+ result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
}
- for (i = 0; i < listArgc; i++) {
- if (i == 0) {
- Tcl_AppendResult(interp, listArgv[0], (char *) NULL);
- } else {
- Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL);
+
+ /*
+ * Now concatenate strings to form the "joined" result. We append
+ * directly into the interpreter's result object.
+ */
+
+ for (i = 0; i < listLen; i++) {
+ bytes = Tcl_GetStringFromObj(elemPtrs[i], &length);
+ if (i > 0) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), joinString,
+ bytes, (char *) NULL);
+ } else {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), bytes, length);
}
}
- ckfree((char *) listArgv);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_LindexCmd --
+ * Tcl_LindexObjCmd --
*
- * This procedure is invoked to process the "lindex" Tcl command.
- * See the user documentation for details on what it does.
+ * This object-based procedure is invoked to process the "lindex" Tcl
+ * command. See the user documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
* See the user documentation.
@@ -727,69 +1803,80 @@ Tcl_JoinCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_LindexCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_LindexObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *p, *element, *next;
- int index, size, parenthesized, result, returnLast;
+ Tcl_Obj *listPtr;
+ Tcl_Obj **elemPtrs;
+ int listLen, index, result;
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " list index\"", (char *) NULL);
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "list index");
return TCL_ERROR;
}
- if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) {
- returnLast = 1;
- index = INT_MAX;
- } else {
- returnLast = 0;
- if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
- return TCL_ERROR;
- }
+
+ /*
+ * Convert the first argument to a list if necessary.
+ */
+
+ listPtr = objv[1];
+ result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ /*
+ * Get the index from objv[2].
+ */
+
+ result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
+ &index);
+ if (result != TCL_OK) {
+ return result;
}
- if (index < 0) {
+ if ((index < 0) || (index >= listLen)) {
+ /*
+ * The index is out of range: the result is an empty string object.
+ */
+
return TCL_OK;
}
- for (p = argv[1] ; index >= 0; index--) {
- result = TclFindElement(interp, p, &element, &next, &size,
- &parenthesized);
+
+ /*
+ * Make sure listPtr still refers to a list object. It might have been
+ * converted to an int above if the argument objects were shared.
+ */
+
+ if (listPtr->typePtr != &tclListType) {
+ result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
+ &elemPtrs);
if (result != TCL_OK) {
return result;
}
- if ((*next == 0) && returnLast) {
- break;
- }
- p = next;
- }
- if (size == 0) {
- return TCL_OK;
- }
- if (size >= TCL_RESULT_SIZE) {
- interp->result = (char *) ckalloc((unsigned) size+1);
- interp->freeProc = TCL_DYNAMIC;
- }
- if (parenthesized) {
- memcpy((VOID *) interp->result, (VOID *) element, (size_t) size);
- interp->result[size] = 0;
- } else {
- TclCopyAndCollapse(size, element, interp->result);
}
+
+ /*
+ * Set the interpreter's object result to the index-th list element.
+ */
+
+ Tcl_SetObjResult(interp, elemPtrs[index]);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_LinsertCmd --
+ * Tcl_LinsertObjCmd --
*
- * This procedure is invoked to process the "linsert" Tcl command.
- * See the user documentation for details on what it does.
+ * This object-based procedure is invoked to process the "linsert" Tcl
+ * command. See the user documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * A new Tcl list object formed by inserting zero or more elements
+ * into a list.
*
* Side effects:
* See the user documentation.
@@ -799,70 +1886,75 @@ Tcl_LindexCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_LinsertCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_LinsertObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ register int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *p, *element, savedChar;
- int i, index, count, result, size;
+ Tcl_Obj *listPtr, *resultPtr;
+ int index, isDuplicate;
+ int result;
- if (argc < 4) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " list index element ?element ...?\"", (char *) NULL);
- return TCL_ERROR;
- }
- if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) {
- index = INT_MAX;
- } else if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?");
return TCL_ERROR;
}
/*
- * Skip over the first "index" elements of the list, then add
- * all of those elements to the result.
+ * Get the index first since, if a conversion to int is needed, it
+ * will invalidate the list's internal representation.
*/
- size = 0;
- element = argv[1];
- for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) {
- result = TclFindElement(interp, p, &element, &p, &size, (int *) NULL);
- if (result != TCL_OK) {
- return result;
- }
- }
- if (*p == 0) {
- Tcl_AppendResult(interp, argv[1], (char *) NULL);
- } else {
- char *end;
-
- end = element+size;
- if (element != argv[1]) {
- while ((*end != 0) && !isspace(UCHAR(*end))) {
- end++;
- }
- }
- savedChar = *end;
- *end = 0;
- Tcl_AppendResult(interp, argv[1], (char *) NULL);
- *end = savedChar;
+ result = TclGetIntForIndex(interp, objv[2], /*endValue*/ INT_MAX,
+ &index);
+ if (result != TCL_OK) {
+ return result;
}
/*
- * Add the new list elements.
+ * If the list object is unshared we can modify it directly. Otherwise
+ * we create a copy to modify: this is "copy on write". We create the
+ * duplicate directly in the interpreter's object result.
*/
-
- for (i = 3; i < argc; i++) {
- Tcl_AppendElement(interp, argv[i]);
+
+ listPtr = objv[1];
+ isDuplicate = 0;
+ if (Tcl_IsShared(listPtr)) {
+ Tcl_ResetResult(interp);
+ resultPtr = Tcl_GetObjResult(interp);
+ if (listPtr->typePtr != NULL) {
+ Tcl_InvalidateStringRep(resultPtr);
+ listPtr->typePtr->dupIntRepProc(listPtr, resultPtr);
+ } else if (listPtr->bytes != NULL) {
+ int len = listPtr->length;
+
+ TclInitStringRep(resultPtr, listPtr->bytes, len);
+ }
+ listPtr = resultPtr;
+ isDuplicate = 1;
}
+
+ if ((objc == 4) && (index == INT_MAX)) {
+ /*
+ * Special case: insert one element at the end of the list.
+ */
+ result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]);
+ } else if (objc > 3) {
+ result = Tcl_ListObjReplace(interp, listPtr, index, 0,
+ (objc-3), &(objv[3]));
+ }
+ if (result != TCL_OK) {
+ return result;
+ }
+
/*
- * Append the remainder of the original list.
+ * Set the interpreter's object result.
*/
- if (*p != 0) {
- Tcl_AppendResult(interp, " ", p, (char *) NULL);
+ if (!isDuplicate) {
+ Tcl_SetObjResult(interp, listPtr);
}
return TCL_OK;
}
@@ -870,13 +1962,13 @@ Tcl_LinsertCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_ListCmd --
+ * Tcl_ListObjCmd --
*
* This procedure is invoked to process the "list" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
* See the user documentation.
@@ -886,15 +1978,19 @@ Tcl_LinsertCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_ListCmd(dummy, interp, argc, argv)
+Tcl_ListObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ register int objc; /* Number of arguments. */
+ register Tcl_Obj *CONST objv[]; /* The argument objects. */
{
- if (argc >= 2) {
- interp->result = Tcl_Merge(argc-1, argv+1);
- interp->freeProc = TCL_DYNAMIC;
+ /*
+ * If there are no list elements, the result is an empty object.
+ * Otherwise modify the interpreter's result object to be a list object.
+ */
+
+ if (objc > 1) {
+ Tcl_SetListObj(Tcl_GetObjResult(interp), (objc-1), &(objv[1]));
}
return TCL_OK;
}
@@ -902,13 +1998,13 @@ Tcl_ListCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_LlengthCmd --
+ * Tcl_LlengthObjCmd --
*
- * This procedure is invoked to process the "llength" Tcl command.
- * See the user documentation for details on what it does.
+ * This object-based procedure is invoked to process the "llength" Tcl
+ * command. See the user documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
* See the user documentation.
@@ -918,44 +2014,43 @@ Tcl_ListCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_LlengthCmd(dummy, interp, argc, argv)
+Tcl_LlengthObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ register Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int count, result;
- char *element, *p;
+ int listLen, result;
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " list\"", (char *) NULL);
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
}
- for (count = 0, p = argv[1]; *p != 0 ; count++) {
- result = TclFindElement(interp, p, &element, &p, (int *) NULL,
- (int *) NULL);
- if (result != TCL_OK) {
- return result;
- }
- if (*element == 0) {
- break;
- }
+
+ result = Tcl_ListObjLength(interp, objv[1], &listLen);
+ if (result != TCL_OK) {
+ return result;
}
- sprintf(interp->result, "%d", count);
+
+ /*
+ * Set the interpreter's object result to an integer object holding the
+ * length.
+ */
+
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), listLen);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_LrangeCmd --
+ * Tcl_LrangeObjCmd --
*
* This procedure is invoked to process the "lrange" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
* See the user documentation.
@@ -965,103 +2060,92 @@ Tcl_LlengthCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_LrangeCmd(notUsed, interp, argc, argv)
+Tcl_LrangeObjCmd(notUsed, interp, objc, objv)
ClientData notUsed; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ register Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int first, last, result;
- char *begin, *end, c, *dummy, *next;
- int count, firstIsEnd;
+ Tcl_Obj *listPtr;
+ Tcl_Obj **elemPtrs;
+ int listLen, first, last, numElems, result;
- if (argc != 4) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " list first last\"", (char *) NULL);
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "list first last");
return TCL_ERROR;
}
- if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) {
- firstIsEnd = 1;
- first = INT_MAX;
- } else {
- firstIsEnd = 0;
- if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
- return TCL_ERROR;
- }
+
+ /*
+ * Make sure the list argument is a list object and get its length and
+ * a pointer to its array of element pointers.
+ */
+
+ listPtr = objv[1];
+ result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ /*
+ * Get the first and last indexes.
+ */
+
+ result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
+ &first);
+ if (result != TCL_OK) {
+ return result;
}
if (first < 0) {
first = 0;
}
- if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
- last = INT_MAX;
- } else {
- if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "expected integer or \"end\" but got \"",
- argv[3], "\"", (char *) NULL);
- return TCL_ERROR;
- }
+
+ result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
+ &last);
+ if (result != TCL_OK) {
+ return result;
}
- if ((first > last) && !firstIsEnd) {
- return TCL_OK;
+ if (last >= listLen) {
+ last = (listLen - 1);
+ }
+
+ if (first > last) {
+ return TCL_OK; /* the result is an empty object */
}
/*
- * Extract a range of fields.
- */
-
- for (count = 0, begin = argv[1]; count < first; begin = next, count++) {
- result = TclFindElement(interp, begin, &dummy, &next, (int *) NULL,
- (int *) NULL);
- if (result != TCL_OK) {
- return result;
- }
- if (*next == 0) {
- if (firstIsEnd) {
- first = count;
- } else {
- begin = next;
- }
- break;
- }
- }
- for (count = first, end = begin; (count <= last) && (*end != 0);
- count++) {
- result = TclFindElement(interp, end, &dummy, &end, (int *) NULL,
- (int *) NULL);
- if (result != TCL_OK) {
- return result;
- }
- }
- if (end == begin) {
- return TCL_OK;
+ * Make sure listPtr still refers to a list object. It might have been
+ * converted to an int above if the argument objects were shared.
+ */
+
+ if (listPtr->typePtr != &tclListType) {
+ result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
+ &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
}
/*
- * Chop off trailing spaces.
+ * Extract a range of fields. We modify the interpreter's result object
+ * to be a list object containing the specified elements.
*/
- while ((end != begin) && (isspace(UCHAR(end[-1])))
- && (((end-1) == begin) || (end[-2] != '\\'))) {
- end--;
- }
- c = *end;
- *end = 0;
- Tcl_SetResult(interp, begin, TCL_VOLATILE);
- *end = c;
+ numElems = (last - first + 1);
+ Tcl_SetListObj(Tcl_GetObjResult(interp), numElems, &(elemPtrs[first]));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_LreplaceCmd --
+ * Tcl_LreplaceObjCmd --
*
- * This procedure is invoked to process the "lreplace" Tcl command.
- * See the user documentation for details on what it does.
+ * This object-based procedure is invoked to process the "lreplace"
+ * Tcl command. See the user documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * A new Tcl list object formed by replacing zero or more elements of
+ * a list.
*
* Side effects:
* See the user documentation.
@@ -1071,123 +2155,99 @@ Tcl_LrangeCmd(notUsed, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_LreplaceCmd(notUsed, interp, argc, argv)
- ClientData notUsed; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *p1, *p2, *element, savedChar, *dummy, *next;
- int i, first, last, count, result, size, firstIsEnd;
+ register Tcl_Obj *listPtr;
+ int createdNewObj, first, last, listLen, numToDelete, result;
- if (argc < 4) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " list first last ?element element ...?\"", (char *) NULL);
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "list first last ?element element ...?");
return TCL_ERROR;
}
- if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) {
- firstIsEnd = 1;
- first = INT_MAX;
- } else {
- firstIsEnd = 0;
- if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad index \"", argv[2],
- "\": must be integer or \"end\"", (char *) NULL);
- return TCL_ERROR;
- }
- }
- if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
- last = INT_MAX;
- } else {
- if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad index \"", argv[3],
- "\": must be integer or \"end\"", (char *) NULL);
- return TCL_ERROR;
- }
- }
- if (first < 0) {
- first = 0;
- }
/*
- * Skip over the elements of the list before "first".
+ * If the list object is unshared we can modify it directly, otherwise
+ * we create a copy to modify: this is "copy on write".
*/
-
- size = 0;
- element = argv[1];
- for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) {
- result = TclFindElement(interp, p1, &element, &next, &size,
- (int *) NULL);
- if (result != TCL_OK) {
- return result;
- }
- if ((*next == 0) && firstIsEnd) {
- break;
- }
- p1 = next;
+
+ listPtr = objv[1];
+ createdNewObj = 0;
+ if (Tcl_IsShared(listPtr)) {
+ listPtr = Tcl_DuplicateObj(listPtr);
+ createdNewObj = 1;
}
- if (*p1 == 0) {
- Tcl_AppendResult(interp, "list doesn't contain element ",
- argv[2], (char *) NULL);
- return TCL_ERROR;
+ result = Tcl_ListObjLength(interp, listPtr, &listLen);
+ if (result != TCL_OK) {
+ errorReturn:
+ if (createdNewObj) {
+ Tcl_DecrRefCount(listPtr); /* free unneeded obj */
+ }
+ return result;
}
/*
- * Skip over the elements of the list up through "last".
+ * Get the first and last indexes.
*/
- for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) {
- result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL,
- (int *) NULL);
- if (result != TCL_OK) {
- return result;
- }
+ result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
+ &first);
+ if (result != TCL_OK) {
+ goto errorReturn;
}
- /*
- * Add the elements before "first" to the result. Remove any
- * trailing white space, to make the result look as clean as
- * possible (this matters primarily if the replacement string is
- * empty).
- */
-
- while ((p1 != argv[1]) && (isspace(UCHAR(p1[-1])))
- && (((p1-1) == argv[1]) || (p1[-2] != '\\'))) {
- p1--;
+ result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
+ &last);
+ if (result != TCL_OK) {
+ goto errorReturn;
}
- savedChar = *p1;
- *p1 = 0;
- Tcl_AppendResult(interp, argv[1], (char *) NULL);
- *p1 = savedChar;
- /*
- * Add the new list elements.
- */
+ if (first < 0) {
+ first = 0;
+ }
+ if (first >= listLen) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "list doesn't contain element ",
+ Tcl_GetStringFromObj(objv[2], (int *) NULL), (int *) NULL);
+ result = TCL_ERROR;
+ goto errorReturn;
+ }
+ if (last >= listLen) {
+ last = (listLen - 1);
+ }
+ if (first <= last) {
+ numToDelete = (last - first + 1);
+ } else {
+ numToDelete = 0;
+ }
- for (i = 4; i < argc; i++) {
- Tcl_AppendElement(interp, argv[i]);
+ if (objc > 4) {
+ result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
+ (objc-4), &(objv[4]));
+ } else {
+ result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
+ 0, NULL);
+ }
+ if (result != TCL_OK) {
+ goto errorReturn;
}
/*
- * Append the remainder of the original list.
+ * Set the interpreter's object result.
*/
- if (*p2 != 0) {
- if (*interp->result == 0) {
- Tcl_SetResult(interp, p2, TCL_VOLATILE);
- } else {
- Tcl_AppendResult(interp, " ", p2, (char *) NULL);
- }
- }
+ Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_LsearchCmd --
+ * Tcl_LsearchObjCmd --
*
* This procedure is invoked to process the "lsearch" Tcl command.
* See the user documentation for details on what it does.
@@ -1201,56 +2261,68 @@ Tcl_LreplaceCmd(notUsed, interp, argc, argv)
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
-Tcl_LsearchCmd(notUsed, interp, argc, argv)
- ClientData notUsed; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_LsearchObjCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument values. */
{
#define EXACT 0
#define GLOB 1
#define REGEXP 2
- int listArgc;
- char **listArgv;
- int i, match, mode, index;
+ char *bytes, *patternBytes;
+ int i, match, mode, index, result, listLen, length, elemLen;
+ Tcl_Obj **elemPtrs;
+ static char *switches[] =
+ {"-exact", "-glob", "-regexp", (char *) NULL};
mode = GLOB;
- if (argc == 4) {
- if (strcmp(argv[1], "-exact") == 0) {
- mode = EXACT;
- } else if (strcmp(argv[1], "-glob") == 0) {
- mode = GLOB;
- } else if (strcmp(argv[1], "-regexp") == 0) {
- mode = REGEXP;
- } else {
- Tcl_AppendResult(interp, "bad search mode \"", argv[1],
- "\": must be -exact, -glob, or -regexp", (char *) NULL);
+ if (objc == 4) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], switches,
+ "search mode", 0, &mode) != TCL_OK) {
return TCL_ERROR;
}
- } else if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ?mode? list pattern\"", (char *) NULL);
+ } else if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?mode? list pattern");
return TCL_ERROR;
}
- if (Tcl_SplitList(interp, argv[argc-2], &listArgc, &listArgv) != TCL_OK) {
- return TCL_ERROR;
+
+ /*
+ * Make sure the list argument is a list object and get its length and
+ * a pointer to its array of element pointers.
+ */
+
+ result = Tcl_ListObjGetElements(interp, objv[objc-2], &listLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
}
+
+ patternBytes = Tcl_GetStringFromObj(objv[objc-1], &length);
+
index = -1;
- for (i = 0; i < listArgc; i++) {
+ for (i = 0; i < listLen; i++) {
match = 0;
+ bytes = Tcl_GetStringFromObj(elemPtrs[i], &elemLen);
switch (mode) {
case EXACT:
- match = (strcmp(listArgv[i], argv[argc-1]) == 0);
+ if (length == elemLen) {
+ match = (memcmp(bytes, patternBytes,
+ (size_t) length) == 0);
+ }
break;
case GLOB:
- match = Tcl_StringMatch(listArgv[i], argv[argc-1]);
+ /*
+ * WARNING: will not work with data containing NULLs.
+ */
+ match = Tcl_StringMatch(bytes, patternBytes);
break;
case REGEXP:
- match = Tcl_RegExpMatch(interp, listArgv[i], argv[argc-1]);
+ /*
+ * WARNING: will not work with data containing NULLs.
+ */
+ match = Tcl_RegExpMatch(interp, bytes, patternBytes);
if (match < 0) {
- ckfree((char *) listArgv);
return TCL_ERROR;
}
break;
@@ -1260,15 +2332,15 @@ Tcl_LsearchCmd(notUsed, interp, argc, argv)
break;
}
}
- sprintf(interp->result, "%d", index);
- ckfree((char *) listArgv);
+
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_LsortCmd --
+ * Tcl_LsortObjCmd --
*
* This procedure is invoked to process the "lsort" Tcl command.
* See the user documentation for details on what it does.
@@ -1282,29 +2354,29 @@ Tcl_LsearchCmd(notUsed, interp, argc, argv)
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
-Tcl_LsortCmd(notUsed, interp, argc, argv)
- ClientData notUsed; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_LsortObjCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument values. */
{
- int listArgc, i, c;
- size_t length;
- char **listArgv;
- char *command = NULL; /* Initialization needed only to
- * prevent compiler warning. */
-
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ?-ascii? ?-integer? ?-real? ?-increasing? ?-decreasing?",
- " ?-command string? list\"", (char *) NULL);
- return TCL_ERROR;
- }
-
- if (sortInterp != NULL) {
- interp->result = "can't invoke \"lsort\" recursively";
+ int i, index, dummy;
+ Tcl_Obj *resultPtr;
+ int length;
+ Tcl_Obj *cmdPtr, **listObjPtrs;
+ SortElement *elementArray;
+ SortElement *elementPtr;
+ SortInfo sortInfo; /* Information about this sort that
+ * needs to be passed to the
+ * comparison function */
+ static char *switches[] =
+ {"-ascii", "-command", "-decreasing", "-dictionary",
+ "-increasing", "-index", "-integer", "-real", (char *) NULL};
+
+ resultPtr = Tcl_GetObjResult(interp);
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?options? list");
return TCL_ERROR;
}
@@ -1312,87 +2384,244 @@ Tcl_LsortCmd(notUsed, interp, argc, argv)
* Parse arguments to set up the mode for the sort.
*/
- sortInterp = interp;
- sortMode = ASCII;
- sortIncreasing = 1;
- sortCode = TCL_OK;
- for (i = 1; i < argc-1; i++) {
- length = strlen(argv[i]);
- if (length < 2) {
- badSwitch:
- Tcl_AppendResult(interp, "bad switch \"", argv[i],
- "\": must be -ascii, -integer, -real, -increasing",
- " -decreasing, or -command", (char *) NULL);
- sortCode = TCL_ERROR;
- goto done;
+ sortInfo.isIncreasing = 1;
+ sortInfo.sortMode = SORTMODE_ASCII;
+ sortInfo.index = -1;
+ sortInfo.interp = interp;
+ sortInfo.resultCode = TCL_OK;
+ cmdPtr = NULL;
+ for (i = 1; i < objc-1; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index)
+ != TCL_OK) {
+ return TCL_ERROR;
}
- c = argv[i][1];
- if ((c == 'a') && (strncmp(argv[i], "-ascii", length) == 0)) {
- sortMode = ASCII;
- } else if ((c == 'c') && (strncmp(argv[i], "-command", length) == 0)) {
- if (i == argc-2) {
- Tcl_AppendResult(interp, "\"-command\" must be",
- " followed by comparison command", (char *) NULL);
- sortCode = TCL_ERROR;
- goto done;
- }
- sortMode = COMMAND;
- command = argv[i+1];
- i++;
- } else if ((c == 'd')
- && (strncmp(argv[i], "-decreasing", length) == 0)) {
- sortIncreasing = 0;
- } else if ((c == 'i') && (length >= 4)
- && (strncmp(argv[i], "-increasing", length) == 0)) {
- sortIncreasing = 1;
- } else if ((c == 'i') && (length >= 4)
- && (strncmp(argv[i], "-integer", length) == 0)) {
- sortMode = INTEGER;
- } else if ((c == 'r')
- && (strncmp(argv[i], "-real", length) == 0)) {
- sortMode = REAL;
- } else {
- goto badSwitch;
+ switch (index) {
+ case 0: /* -ascii */
+ sortInfo.sortMode = SORTMODE_ASCII;
+ break;
+ case 1: /* -command */
+ if (i == (objc-2)) {
+ Tcl_AppendToObj(resultPtr,
+ "\"-command\" option must be followed by comparison command",
+ -1);
+ return TCL_ERROR;
+ }
+ sortInfo.sortMode = SORTMODE_COMMAND;
+ cmdPtr = objv[i+1];
+ i++;
+ break;
+ case 2: /* -decreasing */
+ sortInfo.isIncreasing = 0;
+ break;
+ case 3: /* -dictionary */
+ sortInfo.sortMode = SORTMODE_DICTIONARY;
+ break;
+ case 4: /* -increasing */
+ sortInfo.isIncreasing = 1;
+ break;
+ case 5: /* -index */
+ if (i == (objc-2)) {
+ Tcl_AppendToObj(resultPtr,
+ "\"-index\" option must be followed by list index",
+ -1);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetLongFromObj(interp, objv[i+1], &sortInfo.index)
+ != TCL_OK) {
+ if (strcmp("end", Tcl_GetStringFromObj(objv[i+1], &dummy))
+ == 0) {
+ sortInfo.index = -2;
+ } else {
+ return TCL_ERROR;
+ }
+ }
+ cmdPtr = objv[i+1];
+ i++;
+ break;
+ case 6: /* -integer */
+ sortInfo.sortMode = SORTMODE_INTEGER;
+ break;
+ case 7: /* -real */
+ sortInfo.sortMode = SORTMODE_REAL;
+ break;
}
}
- if (sortMode == COMMAND) {
- Tcl_DStringInit(&sortCmd);
- Tcl_DStringAppend(&sortCmd, command, -1);
+ if (sortInfo.sortMode == SORTMODE_COMMAND) {
+ Tcl_DStringInit(&sortInfo.compareCmd);
+ Tcl_DStringAppend(&sortInfo.compareCmd,
+ Tcl_GetStringFromObj(cmdPtr, &dummy), -1);
}
- if (Tcl_SplitList(interp, argv[argc-1], &listArgc, &listArgv) != TCL_OK) {
- sortCode = TCL_ERROR;
+ sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1],
+ &length, &listObjPtrs);
+ if (sortInfo.resultCode != TCL_OK) {
goto done;
}
- qsort((VOID *) listArgv, (size_t) listArgc, sizeof (char *),
- SortCompareProc);
- if (sortCode == TCL_OK) {
- Tcl_ResetResult(interp);
- interp->result = Tcl_Merge(listArgc, listArgv);
- interp->freeProc = TCL_DYNAMIC;
+ if (length <= 0) {
+ return TCL_OK;
+ }
+ elementArray = (SortElement *) ckalloc(length * sizeof(SortElement));
+ for (i=0; i < length; i++){
+ elementArray[i].objPtr = listObjPtrs[i];
+ elementArray[i].nextPtr = &elementArray[i+1];
}
- if (sortMode == COMMAND) {
- Tcl_DStringFree(&sortCmd);
+ elementArray[length-1].nextPtr = NULL;
+ elementPtr = MergeSort(elementArray, &sortInfo);
+ if (sortInfo.resultCode == TCL_OK) {
+ /*
+ * Note: must clear the interpreter's result object: it could
+ * have been set by the -command script.
+ */
+
+ Tcl_ResetResult(interp);
+ resultPtr = Tcl_GetObjResult(interp);
+ for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
+ Tcl_ListObjAppendElement(interp, resultPtr, elementPtr->objPtr);
+ }
}
- ckfree((char *) listArgv);
+ ckfree((char*) elementArray);
done:
- sortInterp = NULL;
- return sortCode;
+ if (sortInfo.sortMode == SORTMODE_COMMAND) {
+ Tcl_DStringFree(&sortInfo.compareCmd);
+ }
+ return sortInfo.resultCode;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MergeSort -
+ *
+ * This procedure sorts a linked list of SortElement structures
+ * use the merge-sort algorithm.
+ *
+ * Results:
+ * A pointer to the head of the list after sorting is returned.
+ *
+ * Side effects:
+ * None, unless a user-defined comparison command does something
+ * weird.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static SortElement *
+MergeSort(headPtr, infoPtr)
+ SortElement *headPtr; /* First element on the list */
+ SortInfo *infoPtr; /* Information needed by the
+ * comparison operator */
+{
+ /*
+ * The subList array below holds pointers to temporary lists built
+ * during the merge sort. Element i of the array holds a list of
+ * length 2**i.
+ */
+
+# define NUM_LISTS 30
+ SortElement *subList[NUM_LISTS];
+ SortElement *elementPtr;
+ int i;
+
+ for(i = 0; i < NUM_LISTS; i++){
+ subList[i] = NULL;
+ }
+ while (headPtr != NULL) {
+ elementPtr = headPtr;
+ headPtr = headPtr->nextPtr;
+ elementPtr->nextPtr = 0;
+ for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){
+ elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
+ subList[i] = NULL;
+ }
+ if (i >= NUM_LISTS) {
+ i = NUM_LISTS-1;
+ }
+ subList[i] = elementPtr;
+ }
+ elementPtr = NULL;
+ for (i = 0; i < NUM_LISTS; i++){
+ elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
+ }
+ return elementPtr;
}
/*
*----------------------------------------------------------------------
*
- * SortCompareProc --
+ * MergeLists -
+ *
+ * This procedure combines two sorted lists of SortElement structures
+ * into a single sorted list.
+ *
+ * Results:
+ * The unified list of SortElement structures.
+ *
+ * Side effects:
+ * None, unless a user-defined comparison command does something
+ * weird.
*
- * This procedure is invoked by qsort to determine the proper
+ *----------------------------------------------------------------------
+ */
+
+static SortElement *
+MergeLists(leftPtr, rightPtr, infoPtr)
+ SortElement *leftPtr; /* First list to be merged; may be
+ * NULL. */
+ SortElement *rightPtr; /* Second list to be merged; may be
+ * NULL. */
+ SortInfo *infoPtr; /* Information needed by the
+ * comparison operator. */
+{
+ SortElement *headPtr;
+ SortElement *tailPtr;
+
+ if (leftPtr == NULL) {
+ return rightPtr;
+ }
+ if (rightPtr == NULL) {
+ return leftPtr;
+ }
+ if (SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr) > 0) {
+ tailPtr = rightPtr;
+ rightPtr = rightPtr->nextPtr;
+ } else {
+ tailPtr = leftPtr;
+ leftPtr = leftPtr->nextPtr;
+ }
+ headPtr = tailPtr;
+ while ((leftPtr != NULL) && (rightPtr != NULL)) {
+ if (SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr) > 0) {
+ tailPtr->nextPtr = rightPtr;
+ tailPtr = rightPtr;
+ rightPtr = rightPtr->nextPtr;
+ } else {
+ tailPtr->nextPtr = leftPtr;
+ tailPtr = leftPtr;
+ leftPtr = leftPtr->nextPtr;
+ }
+ }
+ if (leftPtr != NULL) {
+ tailPtr->nextPtr = leftPtr;
+ } else {
+ tailPtr->nextPtr = rightPtr;
+ }
+ return headPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SortCompare --
+ *
+ * This procedure is invoked by MergeLists to determine the proper
* ordering between two elements.
*
* Results:
- * < 0 means first is "smaller" than "second", > 0 means "first"
- * is larger than "second", and 0 means they should be treated
- * as equal.
+ * A negative results means the the first element comes before the
+ * second, and a positive results means that the second element
+ * should come first. A result of zero means the two elements
+ * are equal and it doesn't matter which comes first.
*
* Side effects:
* None, unless a user-defined comparison command does something
@@ -1402,15 +2631,17 @@ Tcl_LsortCmd(notUsed, interp, argc, argv)
*/
static int
-SortCompareProc(first, second)
- CONST VOID *first, *second; /* Elements to be compared. */
+SortCompare(objPtr1, objPtr2, infoPtr)
+ Tcl_Obj *objPtr1, *objPtr2; /* Values to be compared. */
+ SortInfo *infoPtr; /* Information passed from the
+ * top-level "lsort" command */
{
- int order;
- char *firstString = *((char **) first);
- char *secondString = *((char **) second);
+ int order, dummy, listLen, index;
+ Tcl_Obj *objPtr;
+ char buffer[30];
order = 0;
- if (sortCode != TCL_OK) {
+ if (infoPtr->resultCode != TCL_OK) {
/*
* Once an error has occurred, skip any future comparisons
* so as to preserve the error message in sortInterp->result.
@@ -1418,16 +2649,77 @@ SortCompareProc(first, second)
return order;
}
- if (sortMode == ASCII) {
- order = strcmp(firstString, secondString);
- } else if (sortMode == INTEGER) {
+ if (infoPtr->index != -1) {
+ /*
+ * The "-index" option was specified. Treat each object as a
+ * list, extract the requested element from each list, and
+ * compare the elements, not the lists. The special index "end"
+ * is signaled here with a large negative index.
+ */
+
+ if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) {
+ infoPtr->resultCode = TCL_ERROR;
+ return order;
+ }
+ if (infoPtr->index < -1) {
+ index = listLen - 1;
+ } else {
+ index = infoPtr->index;
+ }
+
+ if (Tcl_ListObjIndex(infoPtr->interp, objPtr1, index, &objPtr)
+ != TCL_OK) {
+ infoPtr->resultCode = TCL_ERROR;
+ return order;
+ }
+ if (objPtr == NULL) {
+ objPtr = objPtr1;
+ missingElement:
+ sprintf(buffer, "%ld", infoPtr->index);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
+ "element ", buffer, " missing from sublist \"",
+ Tcl_GetStringFromObj(objPtr, (int *) NULL),
+ "\"", (char *) NULL);
+ infoPtr->resultCode = TCL_ERROR;
+ return order;
+ }
+ objPtr1 = objPtr;
+
+ if (Tcl_ListObjLength(infoPtr->interp, objPtr2, &listLen) != TCL_OK) {
+ infoPtr->resultCode = TCL_ERROR;
+ return order;
+ }
+ if (infoPtr->index < -1) {
+ index = listLen - 1;
+ } else {
+ index = infoPtr->index;
+ }
+
+ if (Tcl_ListObjIndex(infoPtr->interp, objPtr2, index, &objPtr)
+ != TCL_OK) {
+ infoPtr->resultCode = TCL_ERROR;
+ return order;
+ }
+ if (objPtr == NULL) {
+ objPtr = objPtr2;
+ goto missingElement;
+ }
+ objPtr2 = objPtr;
+ }
+ if (infoPtr->sortMode == SORTMODE_ASCII) {
+ order = strcmp(Tcl_GetStringFromObj(objPtr1, &dummy),
+ Tcl_GetStringFromObj(objPtr2, &dummy));
+ } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
+ order = DictionaryCompare(
+ Tcl_GetStringFromObj(objPtr1, &dummy),
+ Tcl_GetStringFromObj(objPtr2, &dummy));
+ } else if (infoPtr->sortMode == SORTMODE_INTEGER) {
int a, b;
- if ((Tcl_GetInt(sortInterp, firstString, &a) != TCL_OK)
- || (Tcl_GetInt(sortInterp, secondString, &b) != TCL_OK)) {
- Tcl_AddErrorInfo(sortInterp,
- "\n (converting list element from string to integer)");
- sortCode = TCL_ERROR;
+ if ((Tcl_GetIntFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
+ || (Tcl_GetIntFromObj(infoPtr->interp, objPtr2, &b)
+ != TCL_OK)) {
+ infoPtr->resultCode = TCL_ERROR;
return order;
}
if (a > b) {
@@ -1435,14 +2727,13 @@ SortCompareProc(first, second)
} else if (b > a) {
order = -1;
}
- } else if (sortMode == REAL) {
+ } else if (infoPtr->sortMode == SORTMODE_REAL) {
double a, b;
- if ((Tcl_GetDouble(sortInterp, firstString, &a) != TCL_OK)
- || (Tcl_GetDouble(sortInterp, secondString, &b) != TCL_OK)) {
- Tcl_AddErrorInfo(sortInterp,
- "\n (converting list element from string to real)");
- sortCode = TCL_ERROR;
+ if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
+ || (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b)
+ != TCL_OK)) {
+ infoPtr->resultCode = TCL_ERROR;
return order;
}
if (a > b) {
@@ -1452,21 +2743,23 @@ SortCompareProc(first, second)
}
} else {
int oldLength;
- char *end;
/*
* Generate and evaluate a command to determine which string comes
* first.
*/
- oldLength = Tcl_DStringLength(&sortCmd);
- Tcl_DStringAppendElement(&sortCmd, firstString);
- Tcl_DStringAppendElement(&sortCmd, secondString);
- sortCode = Tcl_Eval(sortInterp, Tcl_DStringValue(&sortCmd));
- Tcl_DStringTrunc(&sortCmd, oldLength);
- if (sortCode != TCL_OK) {
- Tcl_AddErrorInfo(sortInterp,
- "\n (user-defined comparison command)");
+ oldLength = Tcl_DStringLength(&infoPtr->compareCmd);
+ Tcl_DStringAppendElement(&infoPtr->compareCmd,
+ Tcl_GetStringFromObj(objPtr1, &dummy));
+ Tcl_DStringAppendElement(&infoPtr->compareCmd,
+ Tcl_GetStringFromObj(objPtr2, &dummy));
+ infoPtr->resultCode = Tcl_Eval(infoPtr->interp,
+ Tcl_DStringValue(&infoPtr->compareCmd));
+ Tcl_DStringTrunc(&infoPtr->compareCmd, oldLength);
+ if (infoPtr->resultCode != TCL_OK) {
+ Tcl_AddErrorInfo(infoPtr->interp,
+ "\n (-compare command)");
return order;
}
@@ -1474,18 +2767,137 @@ SortCompareProc(first, second)
* Parse the result of the command.
*/
- order = strtol(sortInterp->result, &end, 0);
- if ((end == sortInterp->result) || (*end != 0)) {
- Tcl_ResetResult(sortInterp);
- Tcl_AppendResult(sortInterp,
- "comparison command returned non-numeric result",
- (char *) NULL);
- sortCode = TCL_ERROR;
+ if (Tcl_GetIntFromObj(infoPtr->interp,
+ Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
+ Tcl_ResetResult(infoPtr->interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp),
+ "-compare command returned non-numeric result", -1);
+ infoPtr->resultCode = TCL_ERROR;
return order;
}
}
- if (!sortIncreasing) {
+ if (!infoPtr->isIncreasing) {
order = -order;
}
return order;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictionaryCompare
+ *
+ * This function compares two strings as if they were being used in
+ * an index or card catalog. The case of alphabetic characters is
+ * ignored, except to break ties. Thus "B" comes before "b" but
+ * after "a". Also, integers embedded in the strings compare in
+ * numerical order. In other words, "x10y" comes after "x9y", not
+ * before it as it would when using strcmp().
+ *
+ * Results:
+ * A negative result means that the first element comes before the
+ * second, and a positive result means that the second element
+ * should come first. A result of zero means the two elements
+ * are equal and it doesn't matter which comes first.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictionaryCompare(left, right)
+ char *left, *right; /* The strings to compare */
+{
+ int diff, zeros;
+ int secondaryDiff = 0;
+
+ while (1) {
+ if (isdigit(UCHAR(*right)) && isdigit(UCHAR(*left))) {
+ /*
+ * There are decimal numbers embedded in the two
+ * strings. Compare them as numbers, rather than
+ * strings. If one number has more leading zeros than
+ * the other, the number with more leading zeros sorts
+ * later, but only as a secondary choice.
+ */
+
+ zeros = 0;
+ while (*right == '0') {
+ right++;
+ zeros--;
+ }
+ while (*left == '0') {
+ left++;
+ zeros++;
+ }
+ if (secondaryDiff == 0) {
+ secondaryDiff = zeros;
+ }
+
+ /*
+ * The code below compares the numbers in the two
+ * strings without ever converting them to integers. It
+ * does this by first comparing the lengths of the
+ * numbers and then comparing the digit values.
+ */
+
+ diff = 0;
+ while (1) {
+ if (diff == 0) {
+ diff = *left - *right;
+ }
+ right++;
+ left++;
+ if (!isdigit(UCHAR(*right))) {
+ if (isdigit(UCHAR(*left))) {
+ return 1;
+ } else {
+ /*
+ * The two numbers have the same length. See
+ * if their values are different.
+ */
+
+ if (diff != 0) {
+ return diff;
+ }
+ break;
+ }
+ } else if (!isdigit(UCHAR(*left))) {
+ return -1;
+ }
+ }
+ continue;
+ }
+ diff = *left - *right;
+ if (diff) {
+ if (isupper(UCHAR(*left)) && islower(UCHAR(*right))) {
+ diff = tolower(*left) - *right;
+ if (diff) {
+ return diff;
+ } else if (secondaryDiff == 0) {
+ secondaryDiff = -1;
+ }
+ } else if (isupper(UCHAR(*right)) && islower(UCHAR(*left))) {
+ diff = *left - tolower(UCHAR(*right));
+ if (diff) {
+ return diff;
+ } else if (secondaryDiff == 0) {
+ secondaryDiff = 1;
+ }
+ } else {
+ return diff;
+ }
+ }
+ if (*left == 0) {
+ break;
+ }
+ left++;
+ right++;
+ }
+ if (diff == 0) {
+ diff = secondaryDiff;
+ }
+ return diff;
+}
diff --git a/contrib/tcl/generic/tclCmdMZ.c b/contrib/tcl/generic/tclCmdMZ.c
index 5158ddeea77e..ec1f737dce4a 100644
--- a/contrib/tcl/generic/tclCmdMZ.c
+++ b/contrib/tcl/generic/tclCmdMZ.c
@@ -7,16 +7,17 @@
* those that don't depend much upon UNIX facilities).
*
* Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCmdMZ.c 1.66 96/07/23 16:15:55
+ * SCCS: @(#) tclCmdMZ.c 1.99 97/05/19 17:37:17
*/
#include "tclInt.h"
#include "tclPort.h"
+#include "tclCompile.h"
/*
* Structure used to hold information about variable traces:
@@ -80,7 +81,7 @@ Tcl_PwdCmd(dummy, interp, argc, argv)
if (dirName == NULL) {
return TCL_ERROR;
}
- interp->result = dirName;
+ Tcl_SetResult(interp, dirName, TCL_VOLATILE);
return TCL_OK;
}
@@ -191,7 +192,7 @@ Tcl_RegexpCmd(dummy, interp, argc, argv)
return TCL_ERROR;
}
if (!match) {
- interp->result = "0";
+ Tcl_SetResult(interp, "0", TCL_STATIC);
return TCL_OK;
}
@@ -221,10 +222,14 @@ Tcl_RegexpCmd(dummy, interp, argc, argv)
first = argPtr[1] + (start - string);
last = argPtr[1] + (end - string);
- savedChar = *last;
- *last = 0;
- result = Tcl_SetVar(interp, argPtr[i+2], first, 0);
- *last = savedChar;
+ if (first == last) { /* don't modify argument */
+ result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
+ } else {
+ savedChar = *last;
+ *last = 0;
+ result = Tcl_SetVar(interp, argPtr[i+2], first, 0);
+ *last = savedChar;
+ }
}
}
if (result == NULL) {
@@ -233,7 +238,7 @@ Tcl_RegexpCmd(dummy, interp, argc, argv)
return TCL_ERROR;
}
}
- interp->result = "1";
+ Tcl_SetResult(interp, "1", TCL_STATIC);
return TCL_OK;
}
@@ -264,11 +269,11 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
{
int noCase = 0, all = 0;
Tcl_RegExp regExpr;
- char *string, *pattern, *p, *firstChar, *newValue, **argPtr;
- int match, flags, code, numMatches;
+ char *string, *pattern, *p, *firstChar, **argPtr;
+ int match, code, numMatches;
char *start, *end, *subStart, *subEnd;
register char *src, c;
- Tcl_DString stringDString, patternDString;
+ Tcl_DString stringDString, patternDString, resultDString;
if (argc < 5) {
wrongNumArgs:
@@ -324,6 +329,7 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
pattern = argPtr[0];
string = argPtr[1];
}
+ Tcl_DStringInit(&resultDString);
regExpr = Tcl_RegExpCompile(interp, pattern);
if (regExpr == NULL) {
code = TCL_ERROR;
@@ -337,7 +343,6 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
* then the loop body only gets executed once.
*/
- flags = 0;
numMatches = 0;
for (p = string; *p != 0; ) {
match = Tcl_RegExpExec(interp, regExpr, p, string);
@@ -356,20 +361,7 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
*/
Tcl_RegExpRange(regExpr, 0, &start, &end);
- src = argPtr[1] + (start - string);
- c = *src;
- *src = 0;
- newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string),
- flags);
- *src = c;
- flags = TCL_APPEND_VALUE;
- if (newValue == NULL) {
- cantSet:
- Tcl_AppendResult(interp, "couldn't set variable \"",
- argPtr[3], "\"", (char *) NULL);
- code = TCL_ERROR;
- goto done;
- }
+ Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), start - p);
/*
* Append the subSpec argument to the variable, making appropriate
@@ -390,13 +382,9 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
} else if ((c == '\\') || (c == '&')) {
*src = c;
src[1] = 0;
- newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
- TCL_APPEND_VALUE);
+ Tcl_DStringAppend(&resultDString, firstChar, -1);
*src = '\\';
src[1] = c;
- if (newValue == NULL) {
- goto cantSet;
- }
firstChar = src+2;
src++;
continue;
@@ -409,12 +397,8 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
if (firstChar != src) {
c = *src;
*src = 0;
- newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
- TCL_APPEND_VALUE);
+ Tcl_DStringAppend(&resultDString, firstChar, -1);
*src = c;
- if (newValue == NULL) {
- goto cantSet;
- }
}
Tcl_RegExpRange(regExpr, index, &subStart, &subEnd);
if ((subStart != NULL) && (subEnd != NULL)) {
@@ -424,12 +408,8 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
last = argPtr[1] + (subEnd - string);
saved = *last;
*last = 0;
- newValue = Tcl_SetVar(interp, argPtr[3], first,
- TCL_APPEND_VALUE);
+ Tcl_DStringAppend(&resultDString, first, -1);
*last = saved;
- if (newValue == NULL) {
- goto cantSet;
- }
}
if (*src == '\\') {
src++;
@@ -437,25 +417,16 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
firstChar = src+1;
}
if (firstChar != src) {
- if (Tcl_SetVar(interp, argPtr[3], firstChar,
- TCL_APPEND_VALUE) == NULL) {
- goto cantSet;
- }
+ Tcl_DStringAppend(&resultDString, firstChar, -1);
}
if (end == p) {
- char tmp[2];
/*
* Always consume at least one character of the input string
* in order to prevent infinite loops.
*/
- tmp[0] = argPtr[1][p - string];
- tmp[1] = 0;
- newValue = Tcl_SetVar(interp, argPtr[3], tmp, flags);
- if (newValue == NULL) {
- goto cantSet;
- }
+ Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), 1);
p = end + 1;
} else {
p = end;
@@ -471,32 +442,41 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
*/
if ((*p != 0) || (numMatches == 0)) {
- if (Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string),
- flags) == NULL) {
- goto cantSet;
- }
+ Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), -1);
+ }
+ if (Tcl_SetVar(interp, argPtr[3], Tcl_DStringValue(&resultDString), 0)
+ == NULL) {
+ Tcl_AppendResult(interp,
+ "couldn't set variable \"", argPtr[3], "\"",
+ (char *) NULL);
+ code = TCL_ERROR;
+ } else {
+ char buf[40];
+
+ TclFormatInt(buf, numMatches);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ code = TCL_OK;
}
- sprintf(interp->result, "%d", numMatches);
- code = TCL_OK;
done:
if (noCase) {
Tcl_DStringFree(&stringDString);
Tcl_DStringFree(&patternDString);
}
+ Tcl_DStringFree(&resultDString);
return code;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_RenameCmd --
+ * Tcl_RenameObjCmd --
*
* This procedure is invoked to process the "rename" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
* See the user documentation.
@@ -506,114 +486,34 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_RenameCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_RenameObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Arbitrary value passed to the command. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- register Command *cmdPtr;
- Interp *iPtr = (Interp *) interp;
- Tcl_HashEntry *hPtr;
- int new;
- char *srcName, *dstName;
-
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " oldName newName\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (argv[2][0] == '\0') {
- if (Tcl_DeleteCommand(interp, argv[1]) != 0) {
- Tcl_AppendResult(interp, "can't delete \"", argv[1],
- "\": command doesn't exist", (char *) NULL);
- return TCL_ERROR;
- }
- return TCL_OK;
- }
-
- srcName = argv[1];
- dstName = argv[2];
- hPtr = Tcl_FindHashEntry(&iPtr->commandTable, dstName);
- if (hPtr != NULL) {
- Tcl_AppendResult(interp, "can't rename to \"", argv[2],
- "\": command already exists", (char *) NULL);
- return TCL_ERROR;
- }
-
- /*
- * The code below was added in 11/95 to preserve backwards compatibility
- * when "tkerror" was renamed "bgerror": we guarantee that the hash
- * table entries for both commands refer to a single shared Command
- * structure. This code should eventually become unnecessary.
- */
-
- if ((srcName[0] == 't') && (strcmp(srcName, "tkerror") == 0)) {
- srcName = "bgerror";
- }
- dstName = argv[2];
- if ((dstName[0] == 't') && (strcmp(dstName, "tkerror") == 0)) {
- dstName = "bgerror";
- }
-
- hPtr = Tcl_FindHashEntry(&iPtr->commandTable, srcName);
- if (hPtr == NULL) {
- Tcl_AppendResult(interp, "can't rename \"", argv[1],
- "\": command doesn't exist", (char *) NULL);
- return TCL_ERROR;
- }
- cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
-
- /*
- * Prevent formation of alias loops through renaming.
- */
+ char *oldName, *newName;
- if (TclPreventAliasLoop(interp, interp, dstName, cmdPtr->proc,
- cmdPtr->clientData) != TCL_OK) {
- return TCL_ERROR;
- }
-
- Tcl_DeleteHashEntry(hPtr);
- hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, dstName, &new);
- Tcl_SetHashValue(hPtr, cmdPtr);
- cmdPtr->hPtr = hPtr;
-
- /*
- * The code below provides more backwards compatibility for the
- * "tkerror" => "bgerror" renaming. As with the other compatibility
- * code above, it should eventually be removed.
- */
-
- if ((dstName[0] == 'b') && (strcmp(dstName, "bgerror") == 0)) {
- /*
- * The destination command is "bgerror"; create a "tkerror"
- * command that shares the same Command structure.
- */
-
- hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, "tkerror", &new);
- Tcl_SetHashValue(hPtr, cmdPtr);
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
+ return TCL_ERROR;
}
- if ((srcName[0] == 'b') && (strcmp(srcName, "bgerror") == 0)) {
- /*
- * The source command is "bgerror": delete the hash table
- * entry for "tkerror" if it exists.
- */
- Tcl_DeleteHashEntry(Tcl_FindHashEntry(&iPtr->commandTable, "tkerror"));
- }
- return TCL_OK;
+ oldName = Tcl_GetStringFromObj(objv[1], (int *) NULL);
+ newName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ return TclRenameCommand(interp, oldName, newName);
}
/*
*----------------------------------------------------------------------
*
- * Tcl_ReturnCmd --
+ * Tcl_ReturnObjCmd --
*
- * This procedure is invoked to process the "return" Tcl command.
- * See the user documentation for details on what it does.
+ * This object-based procedure is invoked to process the "return" Tcl
+ * command. See the user documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
* See the user documentation.
@@ -623,14 +523,14 @@ Tcl_RenameCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_ReturnCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_ReturnObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- int c, code;
+ int optionLen, argLen, code, result;
if (iPtr->errorInfo != NULL) {
ckfree(iPtr->errorInfo);
@@ -641,41 +541,64 @@ Tcl_ReturnCmd(dummy, interp, argc, argv)
iPtr->errorCode = NULL;
}
code = TCL_OK;
- for (argv++, argc--; argc > 1; argv += 2, argc -= 2) {
- if (strcmp(argv[0], "-code") == 0) {
- c = argv[1][0];
- if ((c == 'o') && (strcmp(argv[1], "ok") == 0)) {
+
+ /*
+ * THIS FAILS IF AN OBJECT CONTAINS AN EMBEDDED NULL.
+ */
+
+ for (objv++, objc--; objc > 1; objv += 2, objc -= 2) {
+ char *option = Tcl_GetStringFromObj(objv[0], &optionLen);
+ char *arg = Tcl_GetStringFromObj(objv[1], &argLen);
+
+ if (strcmp(option, "-code") == 0) {
+ register int c = arg[0];
+ if ((c == 'o') && (strcmp(arg, "ok") == 0)) {
code = TCL_OK;
- } else if ((c == 'e') && (strcmp(argv[1], "error") == 0)) {
+ } else if ((c == 'e') && (strcmp(arg, "error") == 0)) {
code = TCL_ERROR;
- } else if ((c == 'r') && (strcmp(argv[1], "return") == 0)) {
+ } else if ((c == 'r') && (strcmp(arg, "return") == 0)) {
code = TCL_RETURN;
- } else if ((c == 'b') && (strcmp(argv[1], "break") == 0)) {
+ } else if ((c == 'b') && (strcmp(arg, "break") == 0)) {
code = TCL_BREAK;
- } else if ((c == 'c') && (strcmp(argv[1], "continue") == 0)) {
+ } else if ((c == 'c') && (strcmp(arg, "continue") == 0)) {
code = TCL_CONTINUE;
- } else if (Tcl_GetInt(interp, argv[1], &code) != TCL_OK) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad completion code \"",
- argv[1], "\": must be ok, error, return, break, ",
- "continue, or an integer", (char *) NULL);
- return TCL_ERROR;
+ } else {
+ result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1],
+ &code);
+ if (result != TCL_OK) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "bad completion code \"",
+ Tcl_GetStringFromObj(objv[1], (int *) NULL),
+ "\": must be ok, error, return, break, ",
+ "continue, or an integer", (char *) NULL);
+ return result;
+ }
}
- } else if (strcmp(argv[0], "-errorinfo") == 0) {
- iPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(argv[1]) + 1));
- strcpy(iPtr->errorInfo, argv[1]);
- } else if (strcmp(argv[0], "-errorcode") == 0) {
- iPtr->errorCode = (char *) ckalloc((unsigned) (strlen(argv[1]) + 1));
- strcpy(iPtr->errorCode, argv[1]);
+ } else if (strcmp(option, "-errorinfo") == 0) {
+ iPtr->errorInfo =
+ (char *) ckalloc((unsigned) (strlen(arg) + 1));
+ strcpy(iPtr->errorInfo, arg);
+ } else if (strcmp(option, "-errorcode") == 0) {
+ iPtr->errorCode =
+ (char *) ckalloc((unsigned) (strlen(arg) + 1));
+ strcpy(iPtr->errorCode, arg);
} else {
- Tcl_AppendResult(interp, "bad option \"", argv[0],
- ": must be -code, -errorcode, or -errorinfo",
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "bad option \"", option,
+ "\": must be -code, -errorcode, or -errorinfo",
(char *) NULL);
return TCL_ERROR;
}
}
- if (argc == 1) {
- Tcl_SetResult(interp, argv[0], TCL_VOLATILE);
+
+ if (objc == 1) {
+ /*
+ * Set the interpreter's object result. An inline version of
+ * Tcl_SetObjResult.
+ */
+
+ Tcl_SetObjResult(interp, objv[0]);
}
iPtr->returnCode = code;
return TCL_RETURN;
@@ -728,6 +651,7 @@ Tcl_ScanCmd(dummy, interp, argc, argv)
int numScanned; /* sscanf's result. */
register char *fmt;
int i, widthSpecified, length, code;
+ char buf[40];
/*
* The variables below are used to hold a copy of the format
@@ -799,7 +723,7 @@ Tcl_ScanCmd(dummy, interp, argc, argv)
continue;
}
if (numFields == MAX_FIELDS) {
- interp->result = "too many fields to scan";
+ Tcl_SetResult(interp, "too many fields to scan", TCL_STATIC);
code = TCL_ERROR;
goto done;
}
@@ -826,8 +750,9 @@ Tcl_ScanCmd(dummy, interp, argc, argv)
case 'c':
if (widthSpecified) {
- interp->result =
- "field width may not be specified in %c conversion";
+ Tcl_SetResult(interp,
+ "field width may not be specified in %c conversion",
+ TCL_STATIC);
code = TCL_ERROR;
goto done;
}
@@ -851,7 +776,8 @@ Tcl_ScanCmd(dummy, interp, argc, argv)
do {
fmt++;
if (*fmt == 0) {
- interp->result = "unmatched [ in format string";
+ Tcl_SetResult(interp,
+ "unmatched [ in format string", TCL_STATIC);
code = TCL_ERROR;
goto done;
}
@@ -861,10 +787,14 @@ Tcl_ScanCmd(dummy, interp, argc, argv)
break;
default:
- sprintf(interp->result, "bad scan conversion character \"%c\"",
- *fmt);
- code = TCL_ERROR;
- goto done;
+ {
+ char buf[50];
+
+ sprintf(buf, "bad scan conversion character \"%c\"", *fmt);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ code = TCL_ERROR;
+ goto done;
+ }
}
curField->size = TCL_ALIGN(curField->size);
totalSize += curField->size;
@@ -872,8 +802,9 @@ Tcl_ScanCmd(dummy, interp, argc, argv)
*dst = 0;
if (numFields != (argc-3)) {
- interp->result =
- "different numbers of variable names and field specifiers";
+ Tcl_SetResult(interp,
+ "different numbers of variable names and field specifiers",
+ TCL_STATIC);
code = TCL_ERROR;
goto done;
}
@@ -924,7 +855,7 @@ Tcl_ScanCmd(dummy, interp, argc, argv)
char string[TCL_DOUBLE_SPACE];
case 'd':
- sprintf(string, "%d", *((int *) curField->location));
+ TclFormatInt(string, *((int *) curField->location));
if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
storeError:
Tcl_AppendResult(interp,
@@ -943,7 +874,7 @@ Tcl_ScanCmd(dummy, interp, argc, argv)
break;
case 'c':
- sprintf(string, "%d", *((char *) curField->location) & 0xff);
+ TclFormatInt(string, *((char *) curField->location) & 0xff);
if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
goto storeError;
}
@@ -957,15 +888,16 @@ Tcl_ScanCmd(dummy, interp, argc, argv)
break;
case 'f':
- Tcl_PrintDouble(interp, *((double *) curField->location),
- string);
+ Tcl_PrintDouble((Tcl_Interp *) NULL,
+ *((double *) curField->location), string);
if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
goto storeError;
}
break;
}
}
- sprintf(interp->result, "%d", numScanned);
+ TclFormatInt(buf, numScanned);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
done:
if (results != NULL) {
ckfree(results);
@@ -979,13 +911,13 @@ Tcl_ScanCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_SourceCmd --
+ * Tcl_SourceObjCmd --
*
* This procedure is invoked to process the "source" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
* See the user documentation.
@@ -995,18 +927,27 @@ Tcl_ScanCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_SourceCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_SourceObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " fileName\"", (char *) NULL);
+ char *bytes;
+ int result;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "fileName");
return TCL_ERROR;
}
- return Tcl_EvalFile(interp, argv[1]);
+
+ /*
+ * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL.
+ */
+
+ bytes = Tcl_GetStringFromObj(objv[1], (int *) NULL);
+ result = Tcl_EvalFile(interp, bytes);
+ return result;
}
/*
@@ -1088,7 +1029,7 @@ Tcl_SplitCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_StringCmd --
+ * Tcl_StringObjCmd --
*
* This procedure is invoked to process the "string" Tcl command.
* See the user documentation for details on what it does.
@@ -1104,312 +1045,338 @@ Tcl_SplitCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_StringCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_StringObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- size_t length;
- register char *p;
- int match, c, first;
- int left = 0, right = 0;
-
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option arg ?arg ...?\"", (char *) NULL);
+ int index, first, left, right;
+ Tcl_Obj *resultPtr;
+ char *string1, *string2;
+ int length1, length2;
+ static char *options[] = {
+ "compare", "first", "index", "last",
+ "length", "match", "range", "tolower",
+ "toupper", "trim", "trimleft", "trimright",
+ "wordend", "wordstart", NULL
+ };
+ enum options {
+ STR_COMPARE, STR_FIRST, STR_INDEX, STR_LAST,
+ STR_LENGTH, STR_MATCH, STR_RANGE, STR_TOLOWER,
+ STR_TOUPPER, STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT,
+ STR_WORDEND, STR_WORDSTART
+ };
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
- c = argv[1][0];
- length = strlen(argv[1]);
- if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0)) {
- if (argc != 4) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " compare string1 string2\"", (char *) NULL);
- return TCL_ERROR;
+
+ if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ resultPtr = Tcl_GetObjResult(interp);
+ switch ((enum options) index) {
+ case STR_COMPARE: {
+ int match, length;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string1 string2");
+ return TCL_ERROR;
+ }
+
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ string2 = Tcl_GetStringFromObj(objv[3], &length2);
+
+ length = (length1 < length2) ? length1 : length2;
+ match = memcmp(string1, string2, (unsigned) length);
+ if (match == 0) {
+ match = length1 - length2;
+ }
+ Tcl_SetIntObj(resultPtr, (match > 0) ? 1 : (match < 0) ? -1 : 0);
+ break;
}
- match = strcmp(argv[2], argv[3]);
- if (match > 0) {
- interp->result = "1";
- } else if (match < 0) {
- interp->result = "-1";
- } else {
- interp->result = "0";
+ case STR_FIRST: {
+ first = 1;
+ goto firstlast;
}
- return TCL_OK;
- } else if ((c == 'f') && (strncmp(argv[1], "first", length) == 0)) {
- if (argc != 4) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " first string1 string2\"", (char *) NULL);
- return TCL_ERROR;
+ case STR_INDEX: {
+ int index;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
+ return TCL_ERROR;
+ }
+
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if ((index >= 0) && (index < length1)) {
+ Tcl_SetStringObj(resultPtr, string1 + index, 1);
+ }
+ break;
}
- first = 1;
+ case STR_LAST: {
+ char *p, *end;
+ int match;
- firstLast:
- match = -1;
- c = *argv[2];
- length = strlen(argv[2]);
- for (p = argv[3]; *p != 0; p++) {
- if (*p != c) {
- continue;
+ first = 0;
+
+ firstlast:
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string1 string2");
+ return TCL_ERROR;
}
- if (strncmp(argv[2], p, length) == 0) {
- match = p-argv[3];
- if (first) {
- break;
+
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ string2 = Tcl_GetStringFromObj(objv[3], &length2);
+ match = -1;
+ end = string2 + length2 - length1 + 1;
+ for (p = string2; p < end; p++) {
+ if (memcmp(string1, p, (unsigned) length1) == 0) {
+ match = p - string2;
+ if (first) {
+ break;
+ }
}
}
+ Tcl_SetIntObj(resultPtr, match);
+ break;
}
- sprintf(interp->result, "%d", match);
- return TCL_OK;
- } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)) {
- int index;
+ case STR_LENGTH: {
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string");
+ return TCL_ERROR;
+ }
- if (argc != 4) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " index string charIndex\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) {
- return TCL_ERROR;
- }
- if ((index >= 0) && (index < (int) strlen(argv[2]))) {
- interp->result[0] = argv[2][index];
- interp->result[1] = 0;
- }
- return TCL_OK;
- } else if ((c == 'l') && (strncmp(argv[1], "last", length) == 0)
- && (length >= 2)) {
- if (argc != 4) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " last string1 string2\"", (char *) NULL);
- return TCL_ERROR;
- }
- first = 0;
- goto firstLast;
- } else if ((c == 'l') && (strncmp(argv[1], "length", length) == 0)
- && (length >= 2)) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " length string\"", (char *) NULL);
- return TCL_ERROR;
- }
- sprintf(interp->result, "%d", strlen(argv[2]));
- return TCL_OK;
- } else if ((c == 'm') && (strncmp(argv[1], "match", length) == 0)) {
- if (argc != 4) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " match pattern string\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (Tcl_StringMatch(argv[3], argv[2]) != 0) {
- interp->result = "1";
- } else {
- interp->result = "0";
+ (void) Tcl_GetStringFromObj(objv[2], &length1);
+ Tcl_SetIntObj(resultPtr, length1);
+ break;
}
- return TCL_OK;
- } else if ((c == 'r') && (strncmp(argv[1], "range", length) == 0)) {
- int first, last, stringLength;
+ case STR_MATCH: {
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "pattern string");
+ return TCL_ERROR;
+ }
- if (argc != 5) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " range string first last\"", (char *) NULL);
- return TCL_ERROR;
- }
- stringLength = strlen(argv[2]);
- if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) {
- return TCL_ERROR;
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ string2 = Tcl_GetStringFromObj(objv[3], &length2);
+ Tcl_SetBooleanObj(resultPtr, Tcl_StringMatch(string2, string1));
+ break;
}
- if ((*argv[4] == 'e')
- && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) {
- last = stringLength-1;
- } else {
- if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp,
- "expected integer or \"end\" but got \"",
- argv[4], "\"", (char *) NULL);
+ case STR_RANGE: {
+ int first, last;
+
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string first last");
return TCL_ERROR;
}
- }
- if (first < 0) {
- first = 0;
- }
- if (last >= stringLength) {
- last = stringLength-1;
- }
- if (last >= first) {
- char saved, *p;
- p = argv[2] + last + 1;
- saved = *p;
- *p = 0;
- Tcl_SetResult(interp, argv[2] + first, TCL_VOLATILE);
- *p = saved;
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ if (TclGetIntForIndex(interp, objv[3], length1 - 1,
+ &first) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (TclGetIntForIndex(interp, objv[4], length1 - 1,
+ &last) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (first < 0) {
+ first = 0;
+ }
+ if (last >= length1 - 1) {
+ last = length1 - 1;
+ }
+ if (last >= first) {
+ Tcl_SetStringObj(resultPtr, string1 + first, last - first + 1);
+ }
+ break;
}
- return TCL_OK;
- } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0)
- && (length >= 3)) {
- register char *p;
+ case STR_TOLOWER: {
+ char *p, *end;
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " tolower string\"", (char *) NULL);
- return TCL_ERROR;
- }
- Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
- for (p = interp->result; *p != 0; p++) {
- if (isupper(UCHAR(*p))) {
- *p = (char)tolower(UCHAR(*p));
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string");
+ return TCL_ERROR;
}
- }
- return TCL_OK;
- } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0)
- && (length >= 3)) {
- register char *p;
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " toupper string\"", (char *) NULL);
- return TCL_ERROR;
- }
- Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
- for (p = interp->result; *p != 0; p++) {
- if (islower(UCHAR(*p))) {
- *p = (char) toupper(UCHAR(*p));
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+
+ /*
+ * Since I know resultPtr is not a shared object, I can reach
+ * in and diddle the bytes in its string rep to convert them in
+ * place to lower case.
+ */
+
+ Tcl_SetStringObj(resultPtr, string1, length1);
+ string1 = Tcl_GetStringFromObj(resultPtr, &length1);
+ end = string1 + length1;
+ for (p = string1; p < end; p++) {
+ if (isupper(UCHAR(*p))) {
+ *p = (char) tolower(UCHAR(*p));
+ }
}
+ break;
}
- return TCL_OK;
- } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0)
- && (length == 4)) {
- char *trimChars;
- register char *p, *checkPtr;
-
- left = right = 1;
-
- trim:
- if (argc == 4) {
- trimChars = argv[3];
- } else if (argc == 3) {
- trimChars = " \t\n\r";
- } else {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ", argv[1], " string ?chars?\"", (char *) NULL);
- return TCL_ERROR;
+ case STR_TOUPPER: {
+ char *p, *end;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string");
+ return TCL_ERROR;
+ }
+
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+
+ /*
+ * Since I know resultPtr is not a shared object, I can reach
+ * in and diddle the bytes in its string rep to convert them in
+ * place to upper case.
+ */
+
+ Tcl_SetStringObj(resultPtr, string1, length1);
+ string1 = Tcl_GetStringFromObj(resultPtr, &length1);
+ end = string1 + length1;
+ for (p = string1; p < end; p++) {
+ if (islower(UCHAR(*p))) {
+ *p = (char) toupper(UCHAR(*p));
+ }
+ }
+ break;
}
- p = argv[2];
- if (left) {
- for (c = *p; c != 0; p++, c = *p) {
- for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
- if (*checkPtr == 0) {
- goto doneLeft;
+ case STR_TRIM: {
+ char ch;
+ char *p, *end, *check, *checkEnd;
+
+ left = 1;
+ right = 1;
+
+ trim:
+ if (objc == 4) {
+ string2 = Tcl_GetStringFromObj(objv[3], &length2);
+ } else if (objc == 3) {
+ string2 = " \t\n\r";
+ length2 = strlen(string2);
+ } else {
+ Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?");
+ return TCL_ERROR;
+ }
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ checkEnd = string2 + length2;
+
+ if (left) {
+ end = string1 + length1;
+ for (p = string1; p < end; p++) {
+ ch = *p;
+ for (check = string2; ; check++) {
+ if (check >= checkEnd) {
+ p = end;
+ break;
+ }
+ if (ch == *check) {
+ length1--;
+ string1++;
+ break;
+ }
}
}
}
- }
- doneLeft:
- Tcl_SetResult(interp, p, TCL_VOLATILE);
- if (right) {
- char *donePtr;
-
- p = interp->result + strlen(interp->result) - 1;
- donePtr = &interp->result[-1];
- for (c = *p; p != donePtr; p--, c = *p) {
- for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
- if (*checkPtr == 0) {
- goto doneRight;
+ if (right) {
+ end = string1;
+ for (p = string1 + length1; p > end; ) {
+ p--;
+ ch = *p;
+ for (check = string2; ; check++) {
+ if (check >= checkEnd) {
+ p = end;
+ break;
+ }
+ if (ch == *check) {
+ length1--;
+ break;
+ }
}
}
}
- doneRight:
- p[1] = 0;
- }
- return TCL_OK;
- } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0)
- && (length > 4)) {
- left = 1;
- argv[1] = "trimleft";
- goto trim;
- } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0)
- && (length > 4)) {
- right = 1;
- argv[1] = "trimright";
- goto trim;
- } else if ((c == 'w') && (strncmp(argv[1], "wordend", length) == 0)
- && (length > 4)) {
- int length, index, cur;
- char *string;
-
- if (argc != 4) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ", argv[1], " string index\"", (char *) NULL);
- return TCL_ERROR;
- }
- string = argv[2];
- if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) {
- return TCL_ERROR;
- }
- length = strlen(argv[2]);
- if (index < 0) {
- index = 0;
- }
- if (index >= length) {
- cur = length;
- goto wordendDone;
+ Tcl_SetStringObj(resultPtr, string1, length1);
+ break;
}
- for (cur = index ; cur < length; cur++) {
- c = UCHAR(string[cur]);
- if (!isalnum(c) && (c != '_')) {
- break;
+ case STR_TRIMLEFT: {
+ left = 1;
+ right = 0;
+ goto trim;
+ }
+ case STR_TRIMRIGHT: {
+ left = 0;
+ right = 1;
+ goto trim;
+ }
+ case STR_WORDEND: {
+ int cur, c;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string index");
+ return TCL_ERROR;
}
+
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (index < 0) {
+ index = 0;
+ }
+ cur = length1;
+ if (index < length1) {
+ for (cur = index; cur < length1; cur++) {
+ c = UCHAR(string1[cur]);
+ if (!isalnum(c) && (c != '_')) {
+ break;
+ }
+ }
+ if (cur == index) {
+ cur = index + 1;
+ }
+ }
+ Tcl_SetIntObj(resultPtr, cur);
+ break;
}
- if (cur == index) {
- cur = index+1;
- }
- wordendDone:
- sprintf(interp->result, "%d", cur);
- return TCL_OK;
- } else if ((c == 'w') && (strncmp(argv[1], "wordstart", length) == 0)
- && (length > 4)) {
- int length, index, cur;
- char *string;
-
- if (argc != 4) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ", argv[1], " string index\"", (char *) NULL);
- return TCL_ERROR;
- }
- string = argv[2];
- if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) {
- return TCL_ERROR;
- }
- length = strlen(argv[2]);
- if (index >= length) {
- index = length-1;
- }
- if (index <= 0) {
+ case STR_WORDSTART: {
+ int cur, c;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string index");
+ return TCL_ERROR;
+ }
+
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (index >= length1) {
+ index = length1 - 1;
+ }
cur = 0;
- goto wordstartDone;
- }
- for (cur = index ; cur >= 0; cur--) {
- c = UCHAR(string[cur]);
- if (!isalnum(c) && (c != '_')) {
- break;
+ if (index > 0) {
+ for (cur = index; cur >= 0; cur--) {
+ c = UCHAR(string1[cur]);
+ if (!isalnum(c) && (c != '_')) {
+ break;
+ }
+ }
+ if (cur != index) {
+ cur += 1;
+ }
}
+ Tcl_SetIntObj(resultPtr, cur);
+ break;
}
- if (cur != index) {
- cur += 1;
- }
- wordstartDone:
- sprintf(interp->result, "%d", cur);
- return TCL_OK;
- } else {
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": should be compare, first, index, last, length, match, ",
- "range, tolower, toupper, trim, trimleft, trimright, ",
- "wordend, or wordstart", (char *) NULL);
- return TCL_ERROR;
}
+ return TCL_OK;
}
/*
@@ -1532,7 +1499,7 @@ Tcl_SubstCmd(dummy, interp, argc, argv)
Tcl_DStringFree(&result);
return code;
}
- old = p = iPtr->termPtr+1;
+ old = p = (p+1 + iPtr->termOffset+1);
Tcl_DStringAppend(&result, iPtr->result, -1);
Tcl_ResetResult(interp);
} else {
@@ -1555,13 +1522,13 @@ Tcl_SubstCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_SwitchCmd --
+ * Tcl_SwitchObjCmd --
*
- * This procedure is invoked to process the "switch" Tcl command.
- * See the user documentation for details on what it does.
+ * This object-based procedure is invoked to process the "switch" Tcl
+ * command. See the user documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
* See the user documentation.
@@ -1571,96 +1538,121 @@ Tcl_SubstCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_SwitchCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_SwitchObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
#define EXACT 0
#define GLOB 1
#define REGEXP 2
- int i, code, mode, matched;
- int body;
- char *string;
- int switchArgc, splitArgs;
- char **switchArgv;
-
- switchArgc = argc-1;
- switchArgv = argv+1;
+ int switchObjc, index;
+ Tcl_Obj *CONST *switchObjv;
+ Tcl_Obj *patternObj, *bodyObj;
+ char *string, *pattern, *body;
+ int splitObjs, length, patternLen, i, code, mode, matched, bodyIdx;
+ static char *switches[] =
+ {"-exact", "-glob", "-regexp", "--", (char *) NULL};
+
+ switchObjc = objc-1;
+ switchObjv = objv+1;
mode = EXACT;
- while ((switchArgc > 0) && (*switchArgv[0] == '-')) {
- if (strcmp(*switchArgv, "-exact") == 0) {
- mode = EXACT;
- } else if (strcmp(*switchArgv, "-glob") == 0) {
- mode = GLOB;
- } else if (strcmp(*switchArgv, "-regexp") == 0) {
- mode = REGEXP;
- } else if (strcmp(*switchArgv, "--") == 0) {
- switchArgc--;
- switchArgv++;
- break;
- } else {
- Tcl_AppendResult(interp, "bad option \"", switchArgv[0],
- "\": should be -exact, -glob, -regexp, or --",
- (char *) NULL);
+
+ string = Tcl_GetStringFromObj(switchObjv[0], &length);
+ while ((switchObjc > 0) && (*string == '-')) {
+ if (Tcl_GetIndexFromObj(interp, switchObjv[0], switches,
+ "option", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
- switchArgc--;
- switchArgv++;
+ switch (index) {
+ case 0: /* -exact */
+ mode = EXACT;
+ break;
+ case 1: /* -glob */
+ mode = GLOB;
+ break;
+ case 2: /* -regexp */
+ mode = REGEXP;
+ break;
+ case 3: /* -- */
+ switchObjc--;
+ switchObjv++;
+ goto doneWithSwitches;
+ }
+ switchObjc--;
+ switchObjv++;
+ string = Tcl_GetStringFromObj(switchObjv[0], &length);
}
- if (switchArgc < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " ?switches? string pattern body ... ?default body?\"",
- (char *) NULL);
+
+ doneWithSwitches:
+ if (switchObjc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?switches? string pattern body ... ?default body?");
return TCL_ERROR;
}
- string = *switchArgv;
- switchArgc--;
- switchArgv++;
+
+ string = Tcl_GetStringFromObj(switchObjv[0], &length);
+ switchObjc--;
+ switchObjv++;
/*
* If all of the pattern/command pairs are lumped into a single
* argument, split them out again.
*/
- splitArgs = 0;
- if (switchArgc == 1) {
- code = Tcl_SplitList(interp, switchArgv[0], &switchArgc, &switchArgv);
+ splitObjs = 0;
+ if (switchObjc == 1) {
+ code = Tcl_ListObjLength(interp, switchObjv[0], &switchObjc);
if (code != TCL_OK) {
return code;
}
- splitArgs = 1;
+ splitObjs = 1;
}
- for (i = 0; i < switchArgc; i += 2) {
- if (i == (switchArgc-1)) {
- interp->result = "extra switch pattern with no body";
+ for (i = 0; i < switchObjc; i += 2) {
+ if (i == (switchObjc-1)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "extra switch pattern with no body", -1);
code = TCL_ERROR;
- goto cleanup;
+ goto done;
}
/*
* See if the pattern matches the string.
*/
+ if (splitObjs) {
+ code = Tcl_ListObjIndex(interp, switchObjv[0], i, &patternObj);
+ if (code != TCL_OK) {
+ return code;
+ }
+ pattern = Tcl_GetStringFromObj(patternObj, &patternLen);
+ } else {
+ pattern = Tcl_GetStringFromObj(switchObjv[i], &patternLen);
+ }
+
matched = 0;
- if ((*switchArgv[i] == 'd') && (i == switchArgc-2)
- && (strcmp(switchArgv[i], "default") == 0)) {
+ if ((*pattern == 'd') && (i == switchObjc-2)
+ && (strcmp(pattern, "default") == 0)) {
matched = 1;
} else {
+ /*
+ * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL.
+ */
switch (mode) {
case EXACT:
- matched = (strcmp(string, switchArgv[i]) == 0);
+ matched = (strcmp(string, pattern) == 0);
break;
case GLOB:
- matched = Tcl_StringMatch(string, switchArgv[i]);
+ matched = Tcl_StringMatch(string, pattern);
break;
case REGEXP:
- matched = Tcl_RegExpMatch(interp, string, switchArgv[i]);
+ matched = Tcl_RegExpMatch(interp, string, pattern);
if (matched < 0) {
code = TCL_ERROR;
- goto cleanup;
+ goto done;
}
break;
}
@@ -1670,29 +1662,44 @@ Tcl_SwitchCmd(dummy, interp, argc, argv)
}
/*
- * We've got a match. Find a body to execute, skipping bodies
+ * We've got a match. Find a body to execute, skipping bodies
* that are "-".
*/
- for (body = i+1; ; body += 2) {
- if (body >= switchArgc) {
- Tcl_AppendResult(interp, "no body specified for pattern \"",
- switchArgv[i], "\"", (char *) NULL);
+ for (bodyIdx = i+1; ; bodyIdx += 2) {
+ if (bodyIdx >= switchObjc) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "no body specified for pattern \"", pattern,
+ "\"", (char *) NULL);
code = TCL_ERROR;
- goto cleanup;
+ goto done;
+ }
+
+ if (splitObjs) {
+ code = Tcl_ListObjIndex(interp, switchObjv[0], bodyIdx,
+ &bodyObj);
+ if (code != TCL_OK) {
+ return code;
+ }
+ } else {
+ bodyObj = switchObjv[bodyIdx];
}
- if ((switchArgv[body][0] != '-') || (switchArgv[body][1] != 0)) {
+ /*
+ * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL.
+ */
+ body = Tcl_GetStringFromObj(bodyObj, &length);
+ if ((length != 1) || (body[0] != '-')) {
break;
}
}
- code = Tcl_Eval(interp, switchArgv[body]);
+ code = Tcl_EvalObj(interp, bodyObj);
if (code == TCL_ERROR) {
char msg[100];
- sprintf(msg, "\n (\"%.50s\" arm line %d)", switchArgv[i],
+ sprintf(msg, "\n (\"%.50s\" arm line %d)", pattern,
interp->errorLine);
- Tcl_AddErrorInfo(interp, msg);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
}
- goto cleanup;
+ goto done;
}
/*
@@ -1701,23 +1708,23 @@ Tcl_SwitchCmd(dummy, interp, argc, argv)
code = TCL_OK;
- cleanup:
- if (splitArgs) {
- ckfree((char *) switchArgv);
- }
+ done:
return code;
+#undef EXACT
+#undef GLOB
+#undef REGEXP
}
/*
*----------------------------------------------------------------------
*
- * Tcl_TimeCmd --
+ * Tcl_TimeObjCmd --
*
- * This procedure is invoked to process the "time" Tcl command.
- * See the user documentation for details on what it does.
+ * This object-based procedure is invoked to process the "time" Tcl
+ * command. See the user documentation for details on what it does.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
* See the user documentation.
@@ -1727,45 +1734,48 @@ Tcl_SwitchCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_TimeCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_TimeObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int count, i, result;
- double timePer;
+ register Tcl_Obj *objPtr;
+ register int i, result;
+ int count;
+ double totalMicroSec;
Tcl_Time start, stop;
+ char buf[100];
- if (argc == 2) {
+ if (objc == 2) {
count = 1;
- } else if (argc == 3) {
- if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
- return TCL_ERROR;
+ } else if (objc == 3) {
+ result = Tcl_GetIntFromObj(interp, objv[2], &count);
+ if (result != TCL_OK) {
+ return result;
}
} else {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " command ?count?\"", (char *) NULL);
+ Tcl_WrongNumArgs(interp, 1, objv, "command ?count?");
return TCL_ERROR;
}
+
+ objPtr = objv[1];
+ i = count;
TclpGetTime(&start);
- for (i = count ; i > 0; i--) {
- result = Tcl_Eval(interp, argv[1]);
+ while (i-- > 0) {
+ result = Tcl_EvalObj(interp, objPtr);
if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- char msg[60];
- sprintf(msg, "\n (\"time\" body line %d)",
- interp->errorLine);
- Tcl_AddErrorInfo(interp, msg);
- }
return result;
}
}
TclpGetTime(&stop);
- timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
+
+ totalMicroSec =
+ (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
+ sprintf(buf, "%.0f microseconds per iteration",
+ ((count <= 0) ? 0 : totalMicroSec/count));
Tcl_ResetResult(interp);
- sprintf(interp->result, "%.0f microseconds per iteration",
- (count <= 0) ? 0 : timePer/count);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
return TCL_OK;
}
@@ -1975,11 +1985,13 @@ TraceVarProc(clientData, interp, name1, name2, flags)
int flags; /* OR-ed bits giving operation and other
* information. */
{
+ Interp *iPtr = (Interp *) interp;
TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
char *result;
int code;
Interp dummy;
Tcl_DString cmd;
+ Tcl_Obj *saveObjPtr, *oldObjResultPtr;
result = NULL;
if (tvarPtr->errMsg != NULL) {
@@ -2011,29 +2023,54 @@ TraceVarProc(clientData, interp, name1, name2, flags)
}
/*
- * Execute the command. Be careful to save and restore the
- * result from the interpreter used for the command.
+ * Execute the command. Be careful to save and restore both the
+ * string and object results from the interpreter used for
+ * the command. We discard any object result the command returns.
*/
+ dummy.objResultPtr = Tcl_NewObj();
+ Tcl_IncrRefCount(dummy.objResultPtr);
if (interp->freeProc == 0) {
dummy.freeProc = (Tcl_FreeProc *) 0;
dummy.result = "";
- Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE);
+ Tcl_SetResult((Tcl_Interp *) &dummy, interp->result,
+ TCL_VOLATILE);
} else {
dummy.freeProc = interp->freeProc;
dummy.result = interp->result;
interp->freeProc = (Tcl_FreeProc *) 0;
}
+
+ saveObjPtr = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(saveObjPtr);
+
code = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
- Tcl_DStringFree(&cmd);
- if (code != TCL_OK) {
- tvarPtr->errMsg = (char *) ckalloc((unsigned) (strlen(interp->result) + 1));
+ if (code != TCL_OK) { /* copy error msg to result */
+ tvarPtr->errMsg = (char *)
+ ckalloc((unsigned) (strlen(interp->result) + 1));
strcpy(tvarPtr->errMsg, interp->result);
result = tvarPtr->errMsg;
- Tcl_ResetResult(interp); /* Must clear error state. */
+ Tcl_ResetResult(interp); /* must clear error state. */
}
+
+ /*
+ * Restore the interpreter's string result.
+ */
+
Tcl_SetResult(interp, dummy.result,
(dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc);
+
+ /*
+ * Restore the interpreter's object result from saveObjPtr.
+ */
+
+ oldObjResultPtr = iPtr->objResultPtr;
+ iPtr->objResultPtr = saveObjPtr; /* was incremented above */
+ TclDecrRefCount(oldObjResultPtr);
+
+ Tcl_DecrRefCount(dummy.objResultPtr);
+ dummy.objResultPtr = NULL;
+ Tcl_DStringFree(&cmd);
}
if (flags & TCL_TRACE_DESTROYED) {
result = NULL;
@@ -2050,58 +2087,63 @@ TraceVarProc(clientData, interp, name1, name2, flags)
*
* Tcl_WhileCmd --
*
- * This procedure is invoked to process the "while" Tcl command.
- * See the user documentation for details on what it does.
+ * This procedure is invoked to process the "while" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * With the bytecode compiler, this procedure is only called when
+ * a command name is computed at runtime, and is "while" or the name
+ * to which "while" was renamed: e.g., "set z while; $z {$i<100} {}"
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl result.
*
* Side effects:
- * See the user documentation.
+ * See the user documentation.
*
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
+ /* ARGSUSED */
int
Tcl_WhileCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
{
int result, value;
if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " test command\"", (char *) NULL);
- return TCL_ERROR;
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ argv[0], " test command\"", (char *) NULL);
+ return TCL_ERROR;
}
while (1) {
- result = Tcl_ExprBoolean(interp, argv[1], &value);
- if (result != TCL_OK) {
- return result;
- }
- if (!value) {
- break;
- }
- result = Tcl_Eval(interp, argv[2]);
- if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
- if (result == TCL_ERROR) {
- char msg[60];
- sprintf(msg, "\n (\"while\" body line %d)",
- interp->errorLine);
- Tcl_AddErrorInfo(interp, msg);
- }
- break;
- }
+ result = Tcl_ExprBoolean(interp, argv[1], &value);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (!value) {
+ break;
+ }
+ result = Tcl_Eval(interp, argv[2]);
+ if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
+ if (result == TCL_ERROR) {
+ char msg[60];
+ sprintf(msg, "\n (\"while\" body line %d)",
+ interp->errorLine);
+ Tcl_AddErrorInfo(interp, msg);
+ }
+ break;
+ }
}
if (result == TCL_BREAK) {
- result = TCL_OK;
+ result = TCL_OK;
}
if (result == TCL_OK) {
- Tcl_ResetResult(interp);
+ Tcl_ResetResult(interp);
}
return result;
}
+
diff --git a/contrib/tcl/generic/tclCompExpr.c b/contrib/tcl/generic/tclCompExpr.c
new file mode 100644
index 000000000000..4113879122a5
--- /dev/null
+++ b/contrib/tcl/generic/tclCompExpr.c
@@ -0,0 +1,2290 @@
+/*
+ * tclCompExpr.c --
+ *
+ * This file contains the code to compile Tcl expressions.
+ *
+ * Copyright (c) 1996-1997 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclCompExpr.c 1.30 97/06/13 18:17:20
+ */
+
+#include "tclInt.h"
+#include "tclCompile.h"
+
+/*
+ * The stuff below is a bit of a hack so that this file can be used in
+ * environments that include no UNIX, i.e. no errno: just arrange to use
+ * the errno from tclExecute.c here.
+ */
+
+#ifndef TCL_GENERIC_ONLY
+#include "tclPort.h"
+#else
+#define NO_ERRNO_H
+#endif
+
+#ifdef NO_ERRNO_H
+extern int errno; /* Use errno from tclExecute.c. */
+#define ERANGE 34
+#endif
+
+/*
+ * Boolean variable that controls whether expression compilation tracing
+ * is enabled.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+static int traceCompileExpr = 0;
+#endif /* TCL_COMPILE_DEBUG */
+
+/*
+ * The ExprInfo structure describes the state of compiling an expression.
+ * A pointer to an ExprInfo record is passed among the routines in
+ * this module.
+ */
+
+typedef struct ExprInfo {
+ int token; /* Type of the last token parsed in expr.
+ * See below for definitions. Corresponds
+ * to the characters just before next. */
+ int objIndex; /* If token is a literal value, the index of
+ * an object holding the value in the code's
+ * object table; otherwise is NULL. */
+ char *funcName; /* If the token is FUNC_NAME, points to the
+ * first character of the math function's
+ * name; otherwise is NULL. */
+ char *next; /* Position of the next character to be
+ * scanned in the expression string. */
+ char *originalExpr; /* The entire expression that was originally
+ * passed to Tcl_ExprString et al. */
+ char *lastChar; /* Pointer to terminating null in
+ * originalExpr. */
+ int hasOperators; /* Set 1 if the expr has operators; 0 if
+ * expr is only a primary. If 1 after
+ * compiling an expr, a tryCvtToNumeric
+ * instruction is emitted to convert the
+ * primary to a number if possible. */
+ int exprIsJustVarRef; /* Set 1 if the expr consists of just a
+ * variable reference as in the expression
+ * of "if $b then...". Otherwise 0. Used
+ * to implement expr's 2 level substitution
+ * semantics properly. */
+} ExprInfo;
+
+/*
+ * Definitions of the different tokens that appear in expressions. The order
+ * of these must match the corresponding entries in the operatorStrings
+ * array below.
+ */
+
+#define LITERAL 0
+#define FUNC_NAME (LITERAL + 1)
+#define OPEN_BRACKET (LITERAL + 2)
+#define CLOSE_BRACKET (LITERAL + 3)
+#define OPEN_PAREN (LITERAL + 4)
+#define CLOSE_PAREN (LITERAL + 5)
+#define DOLLAR (LITERAL + 6)
+#define QUOTE (LITERAL + 7)
+#define COMMA (LITERAL + 8)
+#define END (LITERAL + 9)
+#define UNKNOWN (LITERAL + 10)
+
+/*
+ * Binary operators:
+ */
+
+#define MULT (UNKNOWN + 1)
+#define DIVIDE (MULT + 1)
+#define MOD (MULT + 2)
+#define PLUS (MULT + 3)
+#define MINUS (MULT + 4)
+#define LEFT_SHIFT (MULT + 5)
+#define RIGHT_SHIFT (MULT + 6)
+#define LESS (MULT + 7)
+#define GREATER (MULT + 8)
+#define LEQ (MULT + 9)
+#define GEQ (MULT + 10)
+#define EQUAL (MULT + 11)
+#define NEQ (MULT + 12)
+#define BIT_AND (MULT + 13)
+#define BIT_XOR (MULT + 14)
+#define BIT_OR (MULT + 15)
+#define AND (MULT + 16)
+#define OR (MULT + 17)
+#define QUESTY (MULT + 18)
+#define COLON (MULT + 19)
+
+/*
+ * Unary operators. Unary minus and plus are represented by the (binary)
+ * tokens MINUS and PLUS.
+ */
+
+#define NOT (COLON + 1)
+#define BIT_NOT (NOT + 1)
+
+/*
+ * Mapping from tokens to strings; used for debugging messages. These
+ * entries must match the order and number of the token definitions above.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+static char *tokenStrings[] = {
+ "LITERAL", "FUNCNAME",
+ "[", "]", "(", ")", "$", "\"", ",", "END", "UNKNOWN",
+ "*", "/", "%", "+", "-",
+ "<<", ">>", "<", ">", "<=", ">=", "==", "!=",
+ "&", "^", "|", "&&", "||", "?", ":",
+ "!", "~"
+};
+#endif /* TCL_COMPILE_DEBUG */
+
+/*
+ * Declarations for local procedures to this file:
+ */
+
+static int CompileAddExpr _ANSI_ARGS_((Tcl_Interp *interp,
+ ExprInfo *infoPtr, int flags,
+ CompileEnv *envPtr));
+static int CompileBitAndExpr _ANSI_ARGS_((Tcl_Interp *interp,
+ ExprInfo *infoPtr, int flags,
+ CompileEnv *envPtr));
+static int CompileBitOrExpr _ANSI_ARGS_((Tcl_Interp *interp,
+ ExprInfo *infoPtr, int flags,
+ CompileEnv *envPtr));
+static int CompileBitXorExpr _ANSI_ARGS_((Tcl_Interp *interp,
+ ExprInfo *infoPtr, int flags,
+ CompileEnv *envPtr));
+static int CompileCondExpr _ANSI_ARGS_((Tcl_Interp *interp,
+ ExprInfo *infoPtr, int flags,
+ CompileEnv *envPtr));
+static int CompileEqualityExpr _ANSI_ARGS_((Tcl_Interp *interp,
+ ExprInfo *infoPtr, int flags,
+ CompileEnv *envPtr));
+static int CompileLandExpr _ANSI_ARGS_((Tcl_Interp *interp,
+ ExprInfo *infoPtr, int flags,
+ CompileEnv *envPtr));
+static int CompileLorExpr _ANSI_ARGS_((Tcl_Interp *interp,
+ ExprInfo *infoPtr, int flags,
+ CompileEnv *envPtr));
+static int CompileMathFuncCall _ANSI_ARGS_((Tcl_Interp *interp,
+ ExprInfo *infoPtr, int flags,
+ CompileEnv *envPtr));
+static int CompileMultiplyExpr _ANSI_ARGS_((Tcl_Interp *interp,
+ ExprInfo *infoPtr, int flags,
+ CompileEnv *envPtr));
+static int CompilePrimaryExpr _ANSI_ARGS_((Tcl_Interp *interp,
+ ExprInfo *infoPtr, int flags,
+ CompileEnv *envPtr));
+static int CompileRelationalExpr _ANSI_ARGS_((
+ Tcl_Interp *interp, ExprInfo *infoPtr,
+ int flags, CompileEnv *envPtr));
+static int CompileShiftExpr _ANSI_ARGS_((Tcl_Interp *interp,
+ ExprInfo *infoPtr, int flags,
+ CompileEnv *envPtr));
+static int CompileUnaryExpr _ANSI_ARGS_((Tcl_Interp *interp,
+ ExprInfo *infoPtr, int flags,
+ CompileEnv *envPtr));
+static int GetToken _ANSI_ARGS_((Tcl_Interp *interp,
+ ExprInfo *infoPtr, CompileEnv *envPtr));
+
+/*
+ * Macro used to debug the execution of the recursive descent parser used
+ * to compile expressions.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+#define HERE(production, level) \
+ if (traceCompileExpr) { \
+ fprintf(stderr, "%*s%s: token=%s, next=\"%.20s\"\n", \
+ (level), " ", (production), tokenStrings[infoPtr->token], \
+ infoPtr->next); \
+ }
+#else
+#define HERE(production, level)
+#endif /* TCL_COMPILE_DEBUG */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileExpr --
+ *
+ * This procedure compiles a string containing a Tcl expression into
+ * Tcl bytecodes. This procedure is the top-level interface to the
+ * the expression compilation module, and is used by such public
+ * procedures as Tcl_ExprString, Tcl_ExprStringObj, Tcl_ExprLong,
+ * Tcl_ExprDouble, Tcl_ExprBoolean, and Tcl_ExprBooleanObj.
+ *
+ * Note that the topmost recursive-descent parsing routine used by
+ * TclCompileExpr to compile expressions is called "CompileCondExpr"
+ * and not, e.g., "CompileExpr". This is done to avoid an extra
+ * procedure call since such a procedure would only return the result
+ * of calling CompileCondExpr. Other recursive-descent procedures
+ * that need to parse expressions also call CompileCondExpr.
+ *
+ * Results:
+ * The return value is TCL_OK on a successful compilation and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one successfully processed; this might
+ * be the offset of the ']' (if flags & TCL_BRACKET_TERM), or the
+ * offset of the '\0' at the end of the string.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the expression.
+ *
+ * envPtr->exprIsJustVarRef is set 1 if the expression consisted of
+ * a single variable reference as in the expression of "if $b then...".
+ * Otherwise it is set 0. This is used to implement Tcl's two level
+ * expression substitution semantics properly.
+ *
+ * Side effects:
+ * Adds instructions to envPtr to evaluate the expression at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileExpr(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* The source string to compile. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Interp *iPtr = (Interp *) interp;
+ ExprInfo info;
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute the expression. */
+ int result;
+
+#ifdef TCL_COMPILE_DEBUG
+ if (traceCompileExpr) {
+ fprintf(stderr, "expr: string=\"%.30s\"\n", string);
+ }
+#endif /* TCL_COMPILE_DEBUG */
+
+ /*
+ * Register the builtin math functions the first time an expression is
+ * compiled.
+ */
+
+ if (!(iPtr->flags & EXPR_INITIALIZED)) {
+ BuiltinFunc *funcPtr;
+ Tcl_HashEntry *hPtr;
+ MathFunc *mathFuncPtr;
+ int i;
+
+ iPtr->flags |= EXPR_INITIALIZED;
+ i = 0;
+ for (funcPtr = builtinFuncTable; funcPtr->name != NULL; funcPtr++) {
+ Tcl_CreateMathFunc(interp, funcPtr->name,
+ funcPtr->numArgs, funcPtr->argTypes,
+ (Tcl_MathProc *) NULL, (ClientData) 0);
+
+ hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcPtr->name);
+ if (hPtr == NULL) {
+ panic("TclCompileExpr: Tcl_CreateMathFunc incorrectly registered '%s'", funcPtr->name);
+ return TCL_ERROR;
+ }
+ mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
+ mathFuncPtr->builtinFuncIndex = i;
+ i++;
+ }
+ }
+
+ info.token = UNKNOWN;
+ info.objIndex = -1;
+ info.funcName = NULL;
+ info.next = string;
+ info.originalExpr = string;
+ info.lastChar = lastChar;
+ info.hasOperators = 0;
+ info.exprIsJustVarRef = 1; /* will be set 0 if anything else is seen */
+
+ /*
+ * Get the first token then compile an expression.
+ */
+
+ result = GetToken(interp, &info, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ result = CompileCondExpr(interp, &info, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ if (info.token != END) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "syntax error in expression \"", string, "\"", (char *) NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (!info.hasOperators) {
+ /*
+ * Attempt to convert the primary's object to an int or double.
+ * This is done in order to support Tcl's policy of interpreting
+ * operands if at all possible as first integers, else
+ * floating-point numbers.
+ */
+
+ TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
+ }
+ maxDepth = envPtr->maxStackDepth;
+
+ done:
+ envPtr->termOffset = (info.next - string);
+ envPtr->maxStackDepth = maxDepth;
+ envPtr->exprIsJustVarRef = info.exprIsJustVarRef;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileCondExpr --
+ *
+ * This procedure compiles a Tcl conditional expression:
+ * condExpr ::= lorExpr ['?' condExpr ':' condExpr]
+ *
+ * Note that this is the topmost recursive-descent parsing routine used
+ * by TclCompileExpr to compile expressions. It does not call an
+ * separate, higher-level "CompileExpr" procedure. This avoids an extra
+ * procedure call since such a procedure would only return the result
+ * of calling CompileCondExpr. Other recursive-descent procedures that
+ * need to parse expressions also call CompileCondExpr.
+ *
+ * Results:
+ * The return value is TCL_OK on a successful compilation and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the expression.
+ *
+ * Side effects:
+ * Adds instructions to envPtr to evaluate the expression at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileCondExpr(interp, infoPtr, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ ExprInfo *infoPtr; /* Describes the compilation state for the
+ * expression being compiled. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute the expression. */
+ JumpFixup jumpAroundThenFixup, jumpAroundElseFixup;
+ /* Used to update or replace one-byte jumps
+ * around the then and else expressions when
+ * their target PCs are determined. */
+ int elseCodeOffset, currCodeOffset, jumpDist, result;
+
+ HERE("condExpr", 1);
+ result = CompileLorExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+
+ if (infoPtr->token == QUESTY) {
+ result = GetToken(interp, infoPtr, envPtr); /* skip over the '?' */
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ /*
+ * Emit the jump around the "then" clause to the "else" condExpr if
+ * the test was false. We emit a one byte (relative) jump here, and
+ * replace it later with a four byte jump if the jump target is more
+ * than 127 bytes away.
+ */
+
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup);
+
+ /*
+ * Compile the "then" expression. Note that if a subexpression
+ * is only a primary, we need to try to convert it to numeric.
+ * This is done in order to support Tcl's policy of interpreting
+ * operands if at all possible as first integers, else
+ * floating-point numbers.
+ */
+
+ infoPtr->hasOperators = 0;
+ infoPtr->exprIsJustVarRef = 0;
+ result = CompileCondExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ if (infoPtr->token != COLON) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "syntax error in expression \"", infoPtr->originalExpr,
+ "\"", (char *) NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (!infoPtr->hasOperators) {
+ TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
+ }
+ result = GetToken(interp, infoPtr, envPtr); /* skip over the ':' */
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ /*
+ * Emit an unconditional jump around the "else" condExpr.
+ */
+
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
+ &jumpAroundElseFixup);
+
+ /*
+ * Compile the "else" expression.
+ */
+
+ infoPtr->hasOperators = 0;
+ elseCodeOffset = TclCurrCodeOffset();
+ result = CompileCondExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ if (!infoPtr->hasOperators) {
+ TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
+ }
+
+ /*
+ * Fix up the second jump: the unconditional jump around the "else"
+ * expression. If the distance is too great (> 127 bytes), replace
+ * it with a four byte instruction and move the instructions after
+ * the jump down.
+ */
+
+ currCodeOffset = TclCurrCodeOffset();
+ jumpDist = (currCodeOffset - jumpAroundElseFixup.codeOffset);
+ if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, jumpDist, 127)) {
+ /*
+ * Update the else expression's starting code offset since it
+ * moved down 3 bytes too.
+ */
+
+ elseCodeOffset += 3;
+ }
+
+ /*
+ * Now fix up the first branch: the jumpFalse after the test. If the
+ * distance is too great, replace it with a four byte instruction
+ * and update the code offsets for the commands in both the "then"
+ * and "else" expressions.
+ */
+
+ jumpDist = (elseCodeOffset - jumpAroundThenFixup.codeOffset);
+ TclFixupForwardJump(envPtr, &jumpAroundThenFixup, jumpDist, 127);
+
+ infoPtr->hasOperators = 1;
+ }
+
+ done:
+ envPtr->maxStackDepth = maxDepth;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileLorExpr --
+ *
+ * This procedure compiles a Tcl logical or expression:
+ * lorExpr ::= landExpr {'||' landExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful compilation and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the expression.
+ *
+ * Side effects:
+ * Adds instructions to envPtr to evaluate the expression at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileLorExpr(interp, infoPtr, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ ExprInfo *infoPtr; /* Describes the compilation state for the
+ * expression being compiled. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ int maxDepth; /* Maximum number of stack elements needed
+ * to execute the expression. */
+ JumpFixupArray jumpFixupArray;
+ /* Used to fix up the forward "short
+ * circuit" jump after each or-ed
+ * subexpression to just after the last
+ * subexpression. */
+ JumpFixup jumpTrueFixup, jumpFixup;
+ /* Used to emit the jumps in the code to
+ * convert the first operand to a 0 or 1. */
+ int fixupIndex, jumpDist, currCodeOffset, objIndex, j, result;
+ Tcl_Obj *objPtr;
+
+ HERE("lorExpr", 2);
+ result = CompileLandExpr(interp, infoPtr, flags, envPtr);
+ if ((result != TCL_OK) || (infoPtr->token != OR)) {
+ return result; /* envPtr->maxStackDepth is already set */
+ }
+
+ infoPtr->hasOperators = 1;
+ infoPtr->exprIsJustVarRef = 0;
+ maxDepth = envPtr->maxStackDepth;
+ TclInitJumpFixupArray(&jumpFixupArray);
+ while (infoPtr->token == OR) {
+ result = GetToken(interp, infoPtr, envPtr); /* skip over the '||' */
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ if (jumpFixupArray.next == 0) {
+ /*
+ * Just the first "lor" operand is on the stack. The following
+ * is slightly ugly: we need to convert that first "lor" operand
+ * to a "0" or "1" to get the correct result if it is nonzero.
+ * Eventually we'll use a new instruction for this.
+ */
+
+ TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpTrueFixup);
+
+ objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0,
+ /*inHeap*/ 0, envPtr);
+ objPtr = envPtr->objArrayPtr[objIndex];
+
+ Tcl_InvalidateStringRep(objPtr);
+ objPtr->internalRep.longValue = 0;
+ objPtr->typePtr = &tclIntType;
+
+ TclEmitPush(objIndex, envPtr);
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
+
+ jumpDist = (TclCurrCodeOffset() - jumpTrueFixup.codeOffset);
+ if (TclFixupForwardJump(envPtr, &jumpTrueFixup, jumpDist, 127)) {
+ panic("CompileLorExpr: bad jump distance %d\n", jumpDist);
+ }
+ objIndex = TclObjIndexForString("1", 1, /*allocStrRep*/ 0,
+ /*inHeap*/ 0, envPtr);
+ objPtr = envPtr->objArrayPtr[objIndex];
+
+ Tcl_InvalidateStringRep(objPtr);
+ objPtr->internalRep.longValue = 1;
+ objPtr->typePtr = &tclIntType;
+
+ TclEmitPush(objIndex, envPtr);
+
+ jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
+ if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
+ panic("CompileLorExpr: bad jump distance %d\n", jumpDist);
+ }
+ }
+
+ /*
+ * Duplicate the value on top of the stack to prevent the jump from
+ * consuming it.
+ */
+
+ TclEmitOpcode(INST_DUP, envPtr);
+
+ /*
+ * Emit the "short circuit" jump around the rest of the lorExp if
+ * the previous expression was true. We emit a one byte (relative)
+ * jump here, and replace it later with a four byte jump if the jump
+ * target is more than 127 bytes away.
+ */
+
+ if (jumpFixupArray.next == jumpFixupArray.end) {
+ TclExpandJumpFixupArray(&jumpFixupArray);
+ }
+ fixupIndex = jumpFixupArray.next;
+ jumpFixupArray.next++;
+ TclEmitForwardJump(envPtr, TCL_TRUE_JUMP,
+ &(jumpFixupArray.fixup[fixupIndex]));
+
+ /*
+ * Compile the subexpression.
+ */
+
+ result = CompileLandExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
+
+ /*
+ * Emit a "logical or" instruction. This does not try to "short-
+ * circuit" the evaluation of both operands of a Tcl "||" operator,
+ * but instead ensures that we either have a "1" or a "0" result.
+ */
+
+ TclEmitOpcode(INST_LOR, envPtr);
+ }
+
+ /*
+ * Now that we know the target of the forward jumps, update the jumps
+ * with the correct distance. Also, if the distance is too great (> 127
+ * bytes), replace the jump with a four byte instruction and move the
+ * instructions after the jump down.
+ */
+
+ for (j = jumpFixupArray.next; j > 0; j--) {
+ fixupIndex = (j - 1); /* process closest jump first */
+ currCodeOffset = TclCurrCodeOffset();
+ jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset);
+ TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), jumpDist, 127);
+ }
+
+ done:
+ TclFreeJumpFixupArray(&jumpFixupArray);
+ envPtr->maxStackDepth = maxDepth;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileLandExpr --
+ *
+ * This procedure compiles a Tcl logical and expression:
+ * landExpr ::= bitOrExpr {'&&' bitOrExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful compilation and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the expression.
+ *
+ * Side effects:
+ * Adds instructions to envPtr to evaluate the expression at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileLandExpr(interp, infoPtr, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ ExprInfo *infoPtr; /* Describes the compilation state for the
+ * expression being compiled. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ int maxDepth; /* Maximum number of stack elements needed
+ * to execute the expression. */
+ JumpFixupArray jumpFixupArray;
+ /* Used to fix up the forward "short
+ * circuit" jump after each and-ed
+ * subexpression to just after the last
+ * subexpression. */
+ JumpFixup jumpTrueFixup, jumpFixup;
+ /* Used to emit the jumps in the code to
+ * convert the first operand to a 0 or 1. */
+ int fixupIndex, jumpDist, currCodeOffset, objIndex, j, result;
+ Tcl_Obj *objPtr;
+
+ HERE("landExpr", 3);
+ result = CompileBitOrExpr(interp, infoPtr, flags, envPtr);
+ if ((result != TCL_OK) || (infoPtr->token != AND)) {
+ return result; /* envPtr->maxStackDepth is already set */
+ }
+
+ infoPtr->hasOperators = 1;
+ infoPtr->exprIsJustVarRef = 0;
+ maxDepth = envPtr->maxStackDepth;
+ TclInitJumpFixupArray(&jumpFixupArray);
+ while (infoPtr->token == AND) {
+ result = GetToken(interp, infoPtr, envPtr); /* skip over the '&&' */
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ if (jumpFixupArray.next == 0) {
+ /*
+ * Just the first "land" operand is on the stack. The following
+ * is slightly ugly: we need to convert the first "land" operand
+ * to a "0" or "1" to get the correct result if it is
+ * nonzero. Eventually we'll use a new instruction.
+ */
+
+ TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpTrueFixup);
+
+ objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0,
+ /*inHeap*/ 0, envPtr);
+ objPtr = envPtr->objArrayPtr[objIndex];
+
+ Tcl_InvalidateStringRep(objPtr);
+ objPtr->internalRep.longValue = 0;
+ objPtr->typePtr = &tclIntType;
+
+ TclEmitPush(objIndex, envPtr);
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
+
+ jumpDist = (TclCurrCodeOffset() - jumpTrueFixup.codeOffset);
+ if (TclFixupForwardJump(envPtr, &jumpTrueFixup, jumpDist, 127)) {
+ panic("CompileLandExpr: bad jump distance %d\n", jumpDist);
+ }
+ objIndex = TclObjIndexForString("1", 1, /*allocStrRep*/ 0,
+ /*inHeap*/ 0, envPtr);
+ objPtr = envPtr->objArrayPtr[objIndex];
+
+ Tcl_InvalidateStringRep(objPtr);
+ objPtr->internalRep.longValue = 1;
+ objPtr->typePtr = &tclIntType;
+
+ TclEmitPush(objIndex, envPtr);
+
+ jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
+ if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
+ panic("CompileLandExpr: bad jump distance %d\n", jumpDist);
+ }
+ }
+
+ /*
+ * Duplicate the value on top of the stack to prevent the jump from
+ * consuming it.
+ */
+
+ TclEmitOpcode(INST_DUP, envPtr);
+
+ /*
+ * Emit the "short circuit" jump around the rest of the landExp if
+ * the previous expression was false. We emit a one byte (relative)
+ * jump here, and replace it later with a four byte jump if the jump
+ * target is more than 127 bytes away.
+ */
+
+ if (jumpFixupArray.next == jumpFixupArray.end) {
+ TclExpandJumpFixupArray(&jumpFixupArray);
+ }
+ fixupIndex = jumpFixupArray.next;
+ jumpFixupArray.next++;
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
+ &(jumpFixupArray.fixup[fixupIndex]));
+
+ /*
+ * Compile the subexpression.
+ */
+
+ result = CompileBitOrExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
+
+ /*
+ * Emit a "logical and" instruction. This does not try to "short-
+ * circuit" the evaluation of both operands of a Tcl "&&" operator,
+ * but instead ensures that we either have a "1" or a "0" result.
+ */
+
+ TclEmitOpcode(INST_LAND, envPtr);
+ }
+
+ /*
+ * Now that we know the target of the forward jumps, update the jumps
+ * with the correct distance. Also, if the distance is too great (> 127
+ * bytes), replace the jump with a four byte instruction and move the
+ * instructions after the jump down.
+ */
+
+ for (j = jumpFixupArray.next; j > 0; j--) {
+ fixupIndex = (j - 1); /* process closest jump first */
+ currCodeOffset = TclCurrCodeOffset();
+ jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset);
+ TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), jumpDist, 127);
+ }
+
+ done:
+ TclFreeJumpFixupArray(&jumpFixupArray);
+ envPtr->maxStackDepth = maxDepth;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileBitOrExpr --
+ *
+ * This procedure compiles a Tcl bitwise or expression:
+ * bitOrExpr ::= bitXorExpr {'|' bitXorExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful compilation and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the expression.
+ *
+ * Side effects:
+ * Adds instructions to envPtr to evaluate the expression at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileBitOrExpr(interp, infoPtr, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ ExprInfo *infoPtr; /* Describes the compilation state for the
+ * expression being compiled. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute the expression. */
+ int result;
+
+ HERE("bitOrExpr", 4);
+ result = CompileBitXorExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+
+ while (infoPtr->token == BIT_OR) {
+ infoPtr->hasOperators = 1;
+ infoPtr->exprIsJustVarRef = 0;
+ result = GetToken(interp, infoPtr, envPtr); /* skip over the '|' */
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ result = CompileBitXorExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
+
+ TclEmitOpcode(INST_BITOR, envPtr);
+ }
+
+ done:
+ envPtr->maxStackDepth = maxDepth;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileBitXorExpr --
+ *
+ * This procedure compiles a Tcl bitwise exclusive or expression:
+ * bitXorExpr ::= bitAndExpr {'^' bitAndExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful compilation and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the expression.
+ *
+ * Side effects:
+ * Adds instructions to envPtr to evaluate the expression at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileBitXorExpr(interp, infoPtr, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ ExprInfo *infoPtr; /* Describes the compilation state for the
+ * expression being compiled. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute the expression. */
+ int result;
+
+ HERE("bitXorExpr", 5);
+ result = CompileBitAndExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+
+ while (infoPtr->token == BIT_XOR) {
+ infoPtr->hasOperators = 1;
+ infoPtr->exprIsJustVarRef = 0;
+ result = GetToken(interp, infoPtr, envPtr); /* skip over the '^' */
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ result = CompileBitAndExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
+
+ TclEmitOpcode(INST_BITXOR, envPtr);
+ }
+
+ done:
+ envPtr->maxStackDepth = maxDepth;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileBitAndExpr --
+ *
+ * This procedure compiles a Tcl bitwise and expression:
+ * bitAndExpr ::= equalityExpr {'&' equalityExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful compilation and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the expression.
+ *
+ * Side effects:
+ * Adds instructions to envPtr to evaluate the expression at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileBitAndExpr(interp, infoPtr, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ ExprInfo *infoPtr; /* Describes the compilation state for the
+ * expression being compiled. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute the expression. */
+ int result;
+
+ HERE("bitAndExpr", 6);
+ result = CompileEqualityExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+
+ while (infoPtr->token == BIT_AND) {
+ infoPtr->hasOperators = 1;
+ infoPtr->exprIsJustVarRef = 0;
+ result = GetToken(interp, infoPtr, envPtr); /* skip over the '&' */
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ result = CompileEqualityExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
+
+ TclEmitOpcode(INST_BITAND, envPtr);
+ }
+
+ done:
+ envPtr->maxStackDepth = maxDepth;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileEqualityExpr --
+ *
+ * This procedure compiles a Tcl equality (inequality) expression:
+ * equalityExpr ::= relationalExpr {('==' | '!=') relationalExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful compilation and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the expression.
+ *
+ * Side effects:
+ * Adds instructions to envPtr to evaluate the expression at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileEqualityExpr(interp, infoPtr, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ ExprInfo *infoPtr; /* Describes the compilation state for the
+ * expression being compiled. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute the expression. */
+ int op, result;
+
+ HERE("equalityExpr", 7);
+ result = CompileRelationalExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+
+ op = infoPtr->token;
+ while ((op == EQUAL) || (op == NEQ)) {
+ infoPtr->hasOperators = 1;
+ infoPtr->exprIsJustVarRef = 0;
+ result = GetToken(interp, infoPtr, envPtr); /* skip over == or != */
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ result = CompileRelationalExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
+
+ if (op == EQUAL) {
+ TclEmitOpcode(INST_EQ, envPtr);
+ } else {
+ TclEmitOpcode(INST_NEQ, envPtr);
+ }
+
+ op = infoPtr->token;
+ }
+
+ done:
+ envPtr->maxStackDepth = maxDepth;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileRelationalExpr --
+ *
+ * This procedure compiles a Tcl relational expression:
+ * relationalExpr ::= shiftExpr {('<' | '>' | '<=' | '>=') shiftExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful compilation and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the expression.
+ *
+ * Side effects:
+ * Adds instructions to envPtr to evaluate the expression at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileRelationalExpr(interp, infoPtr, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ ExprInfo *infoPtr; /* Describes the compilation state for the
+ * expression being compiled. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute the expression. */
+ int op, result;
+
+ HERE("relationalExpr", 8);
+ result = CompileShiftExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+
+ op = infoPtr->token;
+ while ((op == LESS) || (op == GREATER) || (op == LEQ) || (op == GEQ)) {
+ infoPtr->hasOperators = 1;
+ infoPtr->exprIsJustVarRef = 0;
+ result = GetToken(interp, infoPtr, envPtr); /* skip over the op */
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ result = CompileShiftExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
+
+ switch (op) {
+ case LESS:
+ TclEmitOpcode(INST_LT, envPtr);
+ break;
+ case GREATER:
+ TclEmitOpcode(INST_GT, envPtr);
+ break;
+ case LEQ:
+ TclEmitOpcode(INST_LE, envPtr);
+ break;
+ case GEQ:
+ TclEmitOpcode(INST_GE, envPtr);
+ break;
+ }
+
+ op = infoPtr->token;
+ }
+
+ done:
+ envPtr->maxStackDepth = maxDepth;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileShiftExpr --
+ *
+ * This procedure compiles a Tcl shift expression:
+ * shiftExpr ::= addExpr {('<<' | '>>') addExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful compilation and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the expression.
+ *
+ * Side effects:
+ * Adds instructions to envPtr to evaluate the expression at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileShiftExpr(interp, infoPtr, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ ExprInfo *infoPtr; /* Describes the compilation state for the
+ * expression being compiled. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute the expression. */
+ int op, result;
+
+ HERE("shiftExpr", 9);
+ result = CompileAddExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+
+ op = infoPtr->token;
+ while ((op == LEFT_SHIFT) || (op == RIGHT_SHIFT)) {
+ infoPtr->hasOperators = 1;
+ infoPtr->exprIsJustVarRef = 0;
+ result = GetToken(interp, infoPtr, envPtr); /* skip over << or >> */
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ result = CompileAddExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
+
+ if (op == LEFT_SHIFT) {
+ TclEmitOpcode(INST_LSHIFT, envPtr);
+ } else {
+ TclEmitOpcode(INST_RSHIFT, envPtr);
+ }
+
+ op = infoPtr->token;
+ }
+
+ done:
+ envPtr->maxStackDepth = maxDepth;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileAddExpr --
+ *
+ * This procedure compiles a Tcl addition expression:
+ * addExpr ::= multiplyExpr {('+' | '-') multiplyExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful compilation and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the expression.
+ *
+ * Side effects:
+ * Adds instructions to envPtr to evaluate the expression at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileAddExpr(interp, infoPtr, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ ExprInfo *infoPtr; /* Describes the compilation state for the
+ * expression being compiled. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute the expression. */
+ int op, result;
+
+ HERE("addExpr", 10);
+ result = CompileMultiplyExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+
+ op = infoPtr->token;
+ while ((op == PLUS) || (op == MINUS)) {
+ infoPtr->hasOperators = 1;
+ infoPtr->exprIsJustVarRef = 0;
+ result = GetToken(interp, infoPtr, envPtr); /* skip over + or - */
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ result = CompileMultiplyExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
+
+ if (op == PLUS) {
+ TclEmitOpcode(INST_ADD, envPtr);
+ } else {
+ TclEmitOpcode(INST_SUB, envPtr);
+ }
+
+ op = infoPtr->token;
+ }
+
+ done:
+ envPtr->maxStackDepth = maxDepth;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileMultiplyExpr --
+ *
+ * This procedure compiles a Tcl multiply expression:
+ * multiplyExpr ::= unaryExpr {('*' | '/' | '%') unaryExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful compilation and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the expression.
+ *
+ * Side effects:
+ * Adds instructions to envPtr to evaluate the expression at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileMultiplyExpr(interp, infoPtr, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ ExprInfo *infoPtr; /* Describes the compilation state for the
+ * expression being compiled. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute the expression. */
+ int op, result;
+
+ HERE("multiplyExpr", 11);
+ result = CompileUnaryExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+
+ op = infoPtr->token;
+ while ((op == MULT) || (op == DIVIDE) || (op == MOD)) {
+ infoPtr->hasOperators = 1;
+ infoPtr->exprIsJustVarRef = 0;
+ result = GetToken(interp, infoPtr, envPtr); /* skip over * or / */
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ result = CompileUnaryExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
+
+ if (op == MULT) {
+ TclEmitOpcode(INST_MULT, envPtr);
+ } else if (op == DIVIDE) {
+ TclEmitOpcode(INST_DIV, envPtr);
+ } else {
+ TclEmitOpcode(INST_MOD, envPtr);
+ }
+
+ op = infoPtr->token;
+ }
+
+ done:
+ envPtr->maxStackDepth = maxDepth;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileUnaryExpr --
+ *
+ * This procedure compiles a Tcl unary expression:
+ * unaryExpr ::= ('+' | '-' | '~' | '!') unaryExpr | primaryExpr
+ *
+ * Results:
+ * The return value is TCL_OK on a successful compilation and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the expression.
+ *
+ * Side effects:
+ * Adds instructions to envPtr to evaluate the expression at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileUnaryExpr(interp, infoPtr, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ ExprInfo *infoPtr; /* Describes the compilation state for the
+ * expression being compiled. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute the expression. */
+ int op, result;
+
+ HERE("unaryExpr", 12);
+ op = infoPtr->token;
+ if ((op == PLUS) || (op == MINUS) || (op == BIT_NOT) || (op == NOT)) {
+ infoPtr->hasOperators = 1;
+ infoPtr->exprIsJustVarRef = 0;
+ result = GetToken(interp, infoPtr, envPtr); /* skip over the op */
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ result = CompileUnaryExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+
+ switch (op) {
+ case PLUS:
+ TclEmitOpcode(INST_UPLUS, envPtr);
+ break;
+ case MINUS:
+ TclEmitOpcode(INST_UMINUS, envPtr);
+ break;
+ case BIT_NOT:
+ TclEmitOpcode(INST_BITNOT, envPtr);
+ break;
+ case NOT:
+ TclEmitOpcode(INST_LNOT, envPtr);
+ break;
+ }
+ } else { /* must be a primaryExpr */
+ result = CompilePrimaryExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+ }
+
+ done:
+ envPtr->maxStackDepth = maxDepth;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompilePrimaryExpr --
+ *
+ * This procedure compiles a Tcl primary expression:
+ * primaryExpr ::= literal | varReference | quotedString |
+ * '[' command ']' | mathFuncCall | '(' condExpr ')'
+ *
+ * Results:
+ * The return value is TCL_OK on a successful compilation and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the expression.
+ *
+ * Side effects:
+ * Adds instructions to envPtr to evaluate the expression at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompilePrimaryExpr(interp, infoPtr, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ ExprInfo *infoPtr; /* Describes the compilation state for the
+ * expression being compiled. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute the expression. */
+ int theToken;
+ char *dollarPtr, *quotePtr, *cmdPtr, *termPtr;
+ int result = TCL_OK;
+
+ /*
+ * We emit tryCvtToNumeric instructions after most of these primary
+ * expressions in order to support Tcl's policy of interpreting operands
+ * as first integers if possible, otherwise floating-point numbers if
+ * possible.
+ */
+
+ HERE("primaryExpr", 13);
+ theToken = infoPtr->token;
+
+ if (theToken != DOLLAR) {
+ infoPtr->exprIsJustVarRef = 0;
+ }
+ switch (theToken) {
+ case LITERAL: /* int, double, or string in braces */
+ TclEmitPush(infoPtr->objIndex, envPtr);
+ maxDepth = 1;
+ break;
+
+ case DOLLAR: /* $var variable reference */
+ dollarPtr = (infoPtr->next - 1);
+ envPtr->pushSimpleWords = 1;
+ result = TclCompileDollarVar(interp, dollarPtr,
+ infoPtr->lastChar, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+ infoPtr->next = (dollarPtr + envPtr->termOffset);
+ break;
+
+ case QUOTE: /* quotedString */
+ quotePtr = infoPtr->next;
+ envPtr->pushSimpleWords = 1;
+ result = TclCompileQuotes(interp, quotePtr,
+ infoPtr->lastChar, '"', flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+ infoPtr->next = (quotePtr + envPtr->termOffset);
+ break;
+
+ case OPEN_BRACKET: /* '[' command ']' */
+ cmdPtr = infoPtr->next;
+ envPtr->pushSimpleWords = 1;
+ result = TclCompileString(interp, cmdPtr,
+ infoPtr->lastChar, (flags | TCL_BRACKET_TERM), envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ termPtr = (cmdPtr + envPtr->termOffset);
+ if (*termPtr == ']') {
+ infoPtr->next = (termPtr + 1); /* advance over the ']'. */
+ } else if (termPtr == infoPtr->lastChar) {
+ /*
+ * Missing ] at end of nested command.
+ */
+
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "missing close-bracket", -1);
+ result = TCL_ERROR;
+ goto done;
+ } else {
+ panic("CompilePrimaryExpr: unexpected termination char '%c' for nested command\n", *termPtr);
+ }
+ maxDepth = envPtr->maxStackDepth;
+ break;
+
+ case FUNC_NAME:
+ result = CompileMathFuncCall(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+ break;
+
+ case OPEN_PAREN:
+ result = GetToken(interp, infoPtr, envPtr); /* skip over the '(' */
+ if (result != TCL_OK) {
+ goto done;
+ }
+ result = CompileCondExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+ if (infoPtr->token != CLOSE_PAREN) {
+ goto syntaxError;
+ }
+ break;
+
+ default:
+ goto syntaxError;
+ }
+
+ if (theToken != FUNC_NAME) {
+ /*
+ * Advance to the next token before returning.
+ */
+
+ result = GetToken(interp, infoPtr, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ }
+
+ done:
+ envPtr->maxStackDepth = maxDepth;
+ return result;
+
+ syntaxError:
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "syntax error in expression \"", infoPtr->originalExpr,
+ "\"", (char *) NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileMathFuncCall --
+ *
+ * This procedure compiles a call on a math function in an expression:
+ * mathFuncCall ::= funcName '(' [condExpr {',' condExpr}] ')'
+ *
+ * Results:
+ * The return value is TCL_OK on a successful compilation and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the function.
+ *
+ * Side effects:
+ * Adds instructions to envPtr to evaluate the math function at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileMathFuncCall(interp, infoPtr, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ ExprInfo *infoPtr; /* Describes the compilation state for the
+ * expression being compiled. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Interp *iPtr = (Interp *) interp;
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute the expression. */
+ MathFunc *mathFuncPtr; /* Info about math function. */
+ int objIndex; /* The object array index for an object
+ * holding the function name if it is not
+ * builtin. */
+ Tcl_HashEntry *hPtr;
+ char *p, *funcName;
+ char savedChar;
+ int result, i;
+
+ /*
+ * infoPtr->funcName points to the first character of the math
+ * function's name. Look for the end of its name and look up the
+ * MathFunc record for the function.
+ */
+
+ funcName = p = infoPtr->funcName;
+ while (isalnum(UCHAR(*p)) || (*p == '_')) {
+ p++;
+ }
+ infoPtr->next = p;
+
+ result = GetToken(interp, infoPtr, envPtr); /* skip over func name */
+ if (result != TCL_OK) {
+ goto done;
+ }
+ if (infoPtr->token != OPEN_PAREN) {
+ goto syntaxError;
+ }
+ result = GetToken(interp, infoPtr, envPtr); /* skip over '(' */
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ savedChar = *p;
+ *p = 0;
+ hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
+ if (hPtr == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "unknown math function \"", funcName, "\"", (char *) NULL);
+ result = TCL_ERROR;
+ *p = savedChar;
+ goto done;
+ }
+ mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
+
+ /*
+ * If not a builtin function, push an object with the function's name.
+ */
+
+ if (mathFuncPtr->builtinFuncIndex < 0) { /* not builtin */
+ objIndex = TclObjIndexForString(funcName, -1, /*allocStrRep*/ 1,
+ /*inHeap*/ 0, envPtr);
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = 1;
+ }
+
+ /*
+ * Restore the saved character after the function name.
+ */
+
+ *p = savedChar;
+
+ /*
+ * Compile the arguments for the function, if there are any.
+ */
+
+ if (mathFuncPtr->numArgs > 0) {
+ for (i = 0; ; i++) {
+ result = CompileCondExpr(interp, infoPtr, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ /*
+ * Check for a ',' between arguments or a ')' ending the
+ * argument list.
+ */
+
+ if (i == (mathFuncPtr->numArgs-1)) {
+ if (infoPtr->token == CLOSE_PAREN) {
+ break; /* exit the argument parsing loop */
+ } else if (infoPtr->token == COMMA) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "too many arguments for math function", -1);
+ result = TCL_ERROR;
+ goto done;
+ } else {
+ goto syntaxError;
+ }
+ }
+ if (infoPtr->token != COMMA) {
+ if (infoPtr->token == CLOSE_PAREN) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "too few arguments for math function", -1);
+ result = TCL_ERROR;
+ goto done;
+ } else {
+ goto syntaxError;
+ }
+ }
+ result = GetToken(interp, infoPtr, envPtr); /* skip over , */
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth++;
+ }
+ }
+
+ if (infoPtr->token != CLOSE_PAREN) {
+ goto syntaxError;
+ }
+ result = GetToken(interp, infoPtr, envPtr); /* skip over ')' */
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ /*
+ * Compile the call on the math function. Note that the "objc" argument
+ * count for non-builtin functions is incremented by 1 to include the
+ * the function name itself.
+ */
+
+ if (mathFuncPtr->builtinFuncIndex >= 0) { /* a builtin function */
+ TclEmitInstUInt1(INST_CALL_BUILTIN_FUNC1,
+ mathFuncPtr->builtinFuncIndex, envPtr);
+ } else {
+ TclEmitInstUInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr);
+ }
+
+ done:
+ envPtr->maxStackDepth = maxDepth;
+ return result;
+
+ syntaxError:
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "syntax error in expression \"", infoPtr->originalExpr,
+ "\"", (char *) NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetToken --
+ *
+ * Lexical scanner used to compile expressions: parses a single
+ * operator or other syntactic element from an expression string.
+ *
+ * Results:
+ * TCL_OK is returned unless an error occurred. In that case a standard
+ * Tcl error is returned, using the interpreter's result to hold an
+ * error message. TCL_ERROR is returned if an integer overflow, or a
+ * floating-point overflow or underflow occurred while reading in a
+ * number. If the lexical analysis is successful, infoPtr->token refers
+ * to the next symbol in the expression string, and infoPtr->next is
+ * advanced past the token. Also, if the token is a integer, double, or
+ * string literal, then infoPtr->objIndex the index of an object
+ * holding the value in the code's object table; otherwise is NULL.
+ *
+ * Side effects:
+ * Object are added to envPtr to hold the values of scanned literal
+ * integers, doubles, or strings.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetToken(interp, infoPtr, envPtr)
+ Tcl_Interp *interp; /* Interpreter to use for error
+ * reporting. */
+ register ExprInfo *infoPtr; /* Describes the state of the
+ * compiling the expression,
+ * including the resulting token. */
+ CompileEnv *envPtr; /* Holds objects that store literal
+ * values that are scanned. */
+{
+ register char *src; /* Points to current source char. */
+ register char c; /* The current char. */
+ register int type; /* Current char's CHAR_TYPE type. */
+ char *termPtr; /* Points to char terminating a literal. */
+ char savedChar; /* Holds the character termporarily replaced
+ * by a null character during processing of
+ * literal tokens. */
+ int objIndex; /* The object array index for an object
+ * holding a scanned literal. */
+ long longValue; /* Value of a scanned integer literal. */
+ double doubleValue; /* Value of a scanned double literal. */
+ Tcl_Obj *objPtr;
+
+ /*
+ * First initialize the scanner's "result" fields to default values.
+ */
+
+ infoPtr->token = UNKNOWN;
+ infoPtr->objIndex = -1;
+ infoPtr->funcName = NULL;
+
+ /*
+ * Scan over leading white space at the start of a token. Note that a
+ * backslash-newline is treated as a space.
+ */
+
+ src = infoPtr->next;
+ c = *src;
+ type = CHAR_TYPE(src, infoPtr->lastChar);
+ while ((type & (TCL_SPACE | TCL_BACKSLASH)) || (c == '\n')) {
+ if (type == TCL_BACKSLASH) {
+ if (src[1] == '\n') {
+ src += 2;
+ } else {
+ break; /* no longer white space */
+ }
+ } else {
+ src++;
+ }
+ c = *src;
+ type = CHAR_TYPE(src, infoPtr->lastChar);
+ }
+ if (src == infoPtr->lastChar) {
+ infoPtr->token = END;
+ infoPtr->next = src;
+ return TCL_OK;
+ }
+
+ /*
+ * Try to parse the token first as an integer or floating-point
+ * number. Don't check for a number if the first character is "+" or
+ * "-". If we did, we might treat a binary operator as unary by mistake,
+ * which would eventually cause a syntax error.
+ */
+
+ if ((*src != '+') && (*src != '-')) {
+ int startsWithDigit = isdigit(UCHAR(*src));
+
+ if (startsWithDigit && TclLooksLikeInt(src)) {
+ errno = 0;
+ longValue = strtoul(src, &termPtr, 0);
+ if (errno == ERANGE) {
+ char *s = "integer value too large to represent";
+
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s,
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Find/create an object in envPtr's object array that contains
+ * the integer.
+ */
+
+ savedChar = *termPtr;
+ *termPtr = '\0';
+ objIndex = TclObjIndexForString(src, termPtr - src,
+ /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr);
+ *termPtr = savedChar; /* restore the saved char */
+
+ objPtr = envPtr->objArrayPtr[objIndex];
+ Tcl_InvalidateStringRep(objPtr);
+ objPtr->internalRep.longValue = longValue;
+ objPtr->typePtr = &tclIntType;
+
+ infoPtr->token = LITERAL;
+ infoPtr->objIndex = objIndex;
+ infoPtr->next = termPtr;
+ return TCL_OK;
+ } else if (startsWithDigit || (*src == '.')
+ || (*src == 'n') || (*src == 'N')) {
+ errno = 0;
+ doubleValue = strtod(src, &termPtr);
+ if (termPtr != src) {
+ if (errno != 0) {
+ TclExprFloatError(interp, doubleValue);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Find/create an object in the object array containing the
+ * double.
+ */
+
+ savedChar = *termPtr;
+ *termPtr = '\0';
+ objIndex = TclObjIndexForString(src, termPtr - src,
+ /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ *termPtr = savedChar; /* restore the saved char */
+
+ objPtr = envPtr->objArrayPtr[objIndex];
+ objPtr->internalRep.doubleValue = doubleValue;
+ objPtr->typePtr = &tclDoubleType;
+
+ infoPtr->token = LITERAL;
+ infoPtr->objIndex = objIndex;
+ infoPtr->next = termPtr;
+ return TCL_OK;
+ }
+ }
+ }
+
+ /*
+ * Not an integer or double literal. Check next for a string literal
+ * in braces.
+ */
+
+ if (*src == '{') {
+ int level = 0; /* The {} nesting level. */
+ int hasBackslashNL = 0; /* Nonzero if '\newline' was found. */
+ char *string = src+1; /* Points just after the starting '{'. */
+ char *last; /* Points just before terminating '}'. */
+ int numChars; /* Number of chars in braced string. */
+ char savedChar; /* Holds the character from string
+ * termporarily replaced by a null char
+ * during braced string processing. */
+ int numRead;
+
+ /*
+ * Check first for any backslash-newlines, since we must treat
+ * backslash-newlines specially (they must be replaced by spaces).
+ */
+
+ while (1) {
+ if (src == infoPtr->lastChar) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "missing close-brace", -1);
+ return TCL_ERROR;
+ } else if (CHAR_TYPE(src, infoPtr->lastChar) == TCL_NORMAL) {
+ src++;
+ continue;
+ }
+ c = *src++;
+ if (c == '{') {
+ level++;
+ } else if (c == '}') {
+ --level;
+ if (level == 0) {
+ last = (src - 2); /* i.e. just before terminating } */
+ break;
+ }
+ } else if (c == '\\') {
+ if (*src == '\n') {
+ hasBackslashNL = 1;
+ }
+ (void) Tcl_Backslash(src-1, &numRead);
+ src += numRead - 1;
+ }
+ }
+
+ /*
+ * Create a string object for the braced string. This starts at
+ * "string" and ends just after "last" (which points to the final
+ * character before the terminating '}'). If backslash-newlines were
+ * found, we copy characters one at a time into a heap-allocated
+ * buffer and do backslash-newline substitutions.
+ */
+
+ numChars = (last - string + 1);
+ savedChar = string[numChars];
+ string[numChars] = '\0';
+ if (hasBackslashNL && (numChars > 0)) {
+ char *buffer = ckalloc((unsigned) numChars + 1);
+ register char *dst = buffer;
+ register char *p = string;
+ while (p <= last) {
+ c = *dst++ = *p++;
+ if (c == '\\') {
+ if (*p == '\n') {
+ dst[-1] = Tcl_Backslash(p-1, &numRead);
+ p += numRead - 1;
+ } else {
+ (void) Tcl_Backslash(p-1, &numRead);
+ while (numRead > 1) {
+ *dst++ = *p++;
+ numRead--;
+ }
+ }
+ }
+ }
+ *dst = '\0';
+ objIndex = TclObjIndexForString(buffer, dst - buffer,
+ /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr);
+ } else {
+ objIndex = TclObjIndexForString(string, numChars,
+ /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ }
+ string[numChars] = savedChar; /* restore the saved char */
+
+ infoPtr->token = LITERAL;
+ infoPtr->objIndex = objIndex;
+ infoPtr->next = src;
+ return TCL_OK;
+ }
+
+ /*
+ * Not an literal value.
+ */
+
+ infoPtr->next = src+1; /* assume a 1 char token and advance over it */
+ switch (*src) {
+ case '[':
+ infoPtr->token = OPEN_BRACKET;
+ return TCL_OK;
+
+ case ']':
+ infoPtr->token = CLOSE_BRACKET;
+ return TCL_OK;
+
+ case '(':
+ infoPtr->token = OPEN_PAREN;
+ return TCL_OK;
+
+ case ')':
+ infoPtr->token = CLOSE_PAREN;
+ return TCL_OK;
+
+ case '$':
+ infoPtr->token = DOLLAR;
+ return TCL_OK;
+
+ case '"':
+ infoPtr->token = QUOTE;
+ return TCL_OK;
+
+ case ',':
+ infoPtr->token = COMMA;
+ return TCL_OK;
+
+ case '*':
+ infoPtr->token = MULT;
+ return TCL_OK;
+
+ case '/':
+ infoPtr->token = DIVIDE;
+ return TCL_OK;
+
+ case '%':
+ infoPtr->token = MOD;
+ return TCL_OK;
+
+ case '+':
+ infoPtr->token = PLUS;
+ return TCL_OK;
+
+ case '-':
+ infoPtr->token = MINUS;
+ return TCL_OK;
+
+ case '?':
+ infoPtr->token = QUESTY;
+ return TCL_OK;
+
+ case ':':
+ infoPtr->token = COLON;
+ return TCL_OK;
+
+ case '<':
+ switch (src[1]) {
+ case '<':
+ infoPtr->next = src+2;
+ infoPtr->token = LEFT_SHIFT;
+ break;
+ case '=':
+ infoPtr->next = src+2;
+ infoPtr->token = LEQ;
+ break;
+ default:
+ infoPtr->token = LESS;
+ break;
+ }
+ return TCL_OK;
+
+ case '>':
+ switch (src[1]) {
+ case '>':
+ infoPtr->next = src+2;
+ infoPtr->token = RIGHT_SHIFT;
+ break;
+ case '=':
+ infoPtr->next = src+2;
+ infoPtr->token = GEQ;
+ break;
+ default:
+ infoPtr->token = GREATER;
+ break;
+ }
+ return TCL_OK;
+
+ case '=':
+ if (src[1] == '=') {
+ infoPtr->next = src+2;
+ infoPtr->token = EQUAL;
+ } else {
+ infoPtr->token = UNKNOWN;
+ }
+ return TCL_OK;
+
+ case '!':
+ if (src[1] == '=') {
+ infoPtr->next = src+2;
+ infoPtr->token = NEQ;
+ } else {
+ infoPtr->token = NOT;
+ }
+ return TCL_OK;
+
+ case '&':
+ if (src[1] == '&') {
+ infoPtr->next = src+2;
+ infoPtr->token = AND;
+ } else {
+ infoPtr->token = BIT_AND;
+ }
+ return TCL_OK;
+
+ case '^':
+ infoPtr->token = BIT_XOR;
+ return TCL_OK;
+
+ case '|':
+ if (src[1] == '|') {
+ infoPtr->next = src+2;
+ infoPtr->token = OR;
+ } else {
+ infoPtr->token = BIT_OR;
+ }
+ return TCL_OK;
+
+ case '~':
+ infoPtr->token = BIT_NOT;
+ return TCL_OK;
+
+ default:
+ if (isalpha(UCHAR(*src))) {
+ infoPtr->token = FUNC_NAME;
+ infoPtr->funcName = src;
+ while (isalnum(UCHAR(*src)) || (*src == '_')) {
+ src++;
+ }
+ infoPtr->next = src;
+ return TCL_OK;
+ }
+ infoPtr->next = src+1;
+ infoPtr->token = UNKNOWN;
+ return TCL_OK;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CreateMathFunc --
+ *
+ * Creates a new math function for expressions in a given
+ * interpreter.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The function defined by "name" is created or redefined. If the
+ * function already exists then its definition is replaced; this
+ * includes the builtin functions. Redefining a builtin function forces
+ * all existing code to be invalidated since that code may be compiled
+ * using an instruction specific to the replaced function. In addition,
+ * redefioning a non-builtin function will force existing code to be
+ * invalidated if the number of arguments has changed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
+ Tcl_Interp *interp; /* Interpreter in which function is
+ * to be available. */
+ char *name; /* Name of function (e.g. "sin"). */
+ int numArgs; /* Nnumber of arguments required by
+ * function. */
+ Tcl_ValueType *argTypes; /* Array of types acceptable for
+ * each argument. */
+ Tcl_MathProc *proc; /* Procedure that implements the
+ * math function. */
+ ClientData clientData; /* Additional value to pass to the
+ * function. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_HashEntry *hPtr;
+ MathFunc *mathFuncPtr;
+ int new, i;
+
+ hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new);
+ if (new) {
+ Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc)));
+ }
+ mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
+
+ if (!new) {
+ if (mathFuncPtr->builtinFuncIndex >= 0) {
+ /*
+ * We are redefining a builtin math function. Invalidate the
+ * interpreter's existing code by incrementing its
+ * compileEpoch member. This field is checked in Tcl_EvalObj
+ * and ObjInterpProc, and code whose compilation epoch doesn't
+ * match is recompiled. Newly compiled code will no longer
+ * treat the function as builtin.
+ */
+
+ iPtr->compileEpoch++;
+ } else {
+ /*
+ * A non-builtin function is being redefined. We must invalidate
+ * existing code if the number of arguments has changed. This
+ * is because existing code was compiled assuming that number.
+ */
+
+ if (numArgs != mathFuncPtr->numArgs) {
+ iPtr->compileEpoch++;
+ }
+ }
+ }
+
+ mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */
+ if (numArgs > MAX_MATH_ARGS) {
+ numArgs = MAX_MATH_ARGS;
+ }
+ mathFuncPtr->numArgs = numArgs;
+ for (i = 0; i < numArgs; i++) {
+ mathFuncPtr->argTypes[i] = argTypes[i];
+ }
+ mathFuncPtr->proc = proc;
+ mathFuncPtr->clientData = clientData;
+}
diff --git a/contrib/tcl/generic/tclCompile.c b/contrib/tcl/generic/tclCompile.c
new file mode 100644
index 000000000000..e8aa99cc747a
--- /dev/null
+++ b/contrib/tcl/generic/tclCompile.c
@@ -0,0 +1,7464 @@
+/*
+ * tclCompile.c --
+ *
+ * This file contains procedures that compile Tcl commands or parts
+ * of commands (like quoted strings or nested sub-commands) into a
+ * sequence of instructions ("bytecodes").
+ *
+ * Copyright (c) 1996-1997 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclCompile.c 1.61 97/06/23 18:43:46
+ */
+
+#include "tclInt.h"
+#include "tclCompile.h"
+
+/*
+ * Variable that controls whether compilation tracing is enabled and, if so,
+ * what level of tracing is desired:
+ * 0: no compilation tracing
+ * 1: summarize compilation of top level cmds and proc bodies
+ * 2: display all instructions of each ByteCode compiled
+ * This variable is linked to the Tcl variable "tcl_traceCompile".
+ */
+
+int tclTraceCompile = 0;
+static int traceInitialized = 0;
+
+/*
+ * Count of the number of compilations.
+ */
+
+#ifdef TCL_COMPILE_STATS
+long tclNumCompilations = 0;
+#endif /* TCL_COMPILE_STATS */
+
+/*
+ * A table describing the Tcl bytecode instructions. The entries in this
+ * table must correspond to the list of instructions in tclInt.h. The names
+ * "op1" and "op4" refer to an instruction's one or four byte first operand.
+ * Similarly, "stktop" and "stknext" refer to the topmost and next to
+ * topmost stack elements.
+ *
+ * Note that the load, store, and incr instructions do not distinguish local
+ * from global variables; the bytecode interpreter at runtime uses the
+ * existence of a procedure call frame to distinguish these.
+ */
+
+InstructionDesc instructionTable[] = {
+ /* Name Bytes #Opnds Operand types Stack top, next */
+ {"done", 1, 0, {OPERAND_NONE}},
+ /* Finish ByteCode execution and return stktop (top stack item) */
+ {"push1", 2, 1, {OPERAND_UINT1}},
+ /* Push object at ByteCode objArray[op1] */
+ {"push4", 5, 1, {OPERAND_UINT4}},
+ /* Push object at ByteCode objArray[op4] */
+ {"pop", 1, 0, {OPERAND_NONE}},
+ /* Pop the topmost stack object */
+ {"dup", 1, 0, {OPERAND_NONE}},
+ /* Duplicate the topmost stack object and push the result */
+ {"concat1", 2, 1, {OPERAND_UINT1}},
+ /* Concatenate the top op1 items and push result */
+ {"invokeStk1", 2, 1, {OPERAND_UINT1}},
+ /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */
+ {"invokeStk4", 5, 1, {OPERAND_UINT4}},
+ /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
+ {"evalStk", 1, 0, {OPERAND_NONE}},
+ /* Evaluate command in stktop using Tcl_EvalObj. */
+ {"exprStk", 1, 0, {OPERAND_NONE}},
+ /* Execute expression in stktop using Tcl_ExprStringObj. */
+
+ {"loadScalar1", 2, 1, {OPERAND_UINT1}},
+ /* Load scalar variable at index op1 <= 255 in call frame */
+ {"loadScalar4", 5, 1, {OPERAND_UINT4}},
+ /* Load scalar variable at index op1 >= 256 in call frame */
+ {"loadScalarStk", 1, 0, {OPERAND_NONE}},
+ /* Load scalar variable; scalar's name is stktop */
+ {"loadArray1", 2, 1, {OPERAND_UINT1}},
+ /* Load array element; array at slot op1<=255, element is stktop */
+ {"loadArray4", 5, 1, {OPERAND_UINT4}},
+ /* Load array element; array at slot op1 > 255, element is stktop */
+ {"loadArrayStk", 1, 0, {OPERAND_NONE}},
+ /* Load array element; element is stktop, array name is stknext */
+ {"loadStk", 1, 0, {OPERAND_NONE}},
+ /* Load general variable; unparsed variable name is stktop */
+ {"storeScalar1", 2, 1, {OPERAND_UINT1}},
+ /* Store scalar variable at op1<=255 in frame; value is stktop */
+ {"storeScalar4", 5, 1, {OPERAND_UINT4}},
+ /* Store scalar variable at op1 > 255 in frame; value is stktop */
+ {"storeScalarStk", 1, 0, {OPERAND_NONE}},
+ /* Store scalar; value is stktop, scalar name is stknext */
+ {"storeArray1", 2, 1, {OPERAND_UINT1}},
+ /* Store array element; array at op1<=255, value is top then elem */
+ {"storeArray4", 5, 1, {OPERAND_UINT4}},
+ /* Store array element; array at op1>=256, value is top then elem */
+ {"storeArrayStk", 1, 0, {OPERAND_NONE}},
+ /* Store array element; value is stktop, then elem, array names */
+ {"storeStk", 1, 0, {OPERAND_NONE}},
+ /* Store general variable; value is stktop, then unparsed name */
+
+ {"incrScalar1", 2, 1, {OPERAND_UINT1}},
+ /* Incr scalar at index op1<=255 in frame; incr amount is stktop */
+ {"incrScalarStk", 1, 0, {OPERAND_NONE}},
+ /* Incr scalar; incr amount is stktop, scalar's name is stknext */
+ {"incrArray1", 2, 1, {OPERAND_UINT1}},
+ /* Incr array elem; arr at slot op1<=255, amount is top then elem */
+ {"incrArrayStk", 1, 0, {OPERAND_NONE}},
+ /* Incr array element; amount is top then elem then array names */
+ {"incrStk", 1, 0, {OPERAND_NONE}},
+ /* Incr general variable; amount is stktop then unparsed var name */
+ {"incrScalar1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}},
+ /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */
+ {"incrScalarStkImm", 2, 1, {OPERAND_INT1}},
+ /* Incr scalar; scalar name is stktop; incr amount is op1 */
+ {"incrArray1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}},
+ /* Incr array elem; array at slot op1 <= 255, elem is stktop,
+ * amount is 2nd operand byte */
+ {"incrArrayStkImm", 2, 1, {OPERAND_INT1}},
+ /* Incr array element; elem is top then array name, amount is op1 */
+ {"incrStkImm", 2, 1, {OPERAND_INT1}},
+ /* Incr general variable; unparsed name is top, amount is op1 */
+
+ {"jump1", 2, 1, {OPERAND_INT1}},
+ /* Jump relative to (pc + op1) */
+ {"jump4", 5, 1, {OPERAND_INT4}},
+ /* Jump relative to (pc + op4) */
+ {"jumpTrue1", 2, 1, {OPERAND_INT1}},
+ /* Jump relative to (pc + op1) if stktop expr object is true */
+ {"jumpTrue4", 5, 1, {OPERAND_INT4}},
+ /* Jump relative to (pc + op4) if stktop expr object is true */
+ {"jumpFalse1", 2, 1, {OPERAND_INT1}},
+ /* Jump relative to (pc + op1) if stktop expr object is false */
+ {"jumpFalse4", 5, 1, {OPERAND_INT4}},
+ /* Jump relative to (pc + op4) if stktop expr object is false */
+
+ {"lor", 1, 0, {OPERAND_NONE}},
+ /* Logical or: push (stknext || stktop) */
+ {"land", 1, 0, {OPERAND_NONE}},
+ /* Logical and: push (stknext && stktop) */
+ {"bitor", 1, 0, {OPERAND_NONE}},
+ /* Bitwise or: push (stknext | stktop) */
+ {"bitxor", 1, 0, {OPERAND_NONE}},
+ /* Bitwise xor push (stknext ^ stktop) */
+ {"bitand", 1, 0, {OPERAND_NONE}},
+ /* Bitwise and: push (stknext & stktop) */
+ {"eq", 1, 0, {OPERAND_NONE}},
+ /* Equal: push (stknext == stktop) */
+ {"neq", 1, 0, {OPERAND_NONE}},
+ /* Not equal: push (stknext != stktop) */
+ {"lt", 1, 0, {OPERAND_NONE}},
+ /* Less: push (stknext < stktop) */
+ {"gt", 1, 0, {OPERAND_NONE}},
+ /* Greater: push (stknext || stktop) */
+ {"le", 1, 0, {OPERAND_NONE}},
+ /* Logical or: push (stknext || stktop) */
+ {"ge", 1, 0, {OPERAND_NONE}},
+ /* Logical or: push (stknext || stktop) */
+ {"lshift", 1, 0, {OPERAND_NONE}},
+ /* Left shift: push (stknext << stktop) */
+ {"rshift", 1, 0, {OPERAND_NONE}},
+ /* Right shift: push (stknext >> stktop) */
+ {"add", 1, 0, {OPERAND_NONE}},
+ /* Add: push (stknext + stktop) */
+ {"sub", 1, 0, {OPERAND_NONE}},
+ /* Sub: push (stkext - stktop) */
+ {"mult", 1, 0, {OPERAND_NONE}},
+ /* Multiply: push (stknext * stktop) */
+ {"div", 1, 0, {OPERAND_NONE}},
+ /* Divide: push (stknext / stktop) */
+ {"mod", 1, 0, {OPERAND_NONE}},
+ /* Mod: push (stknext % stktop) */
+ {"uplus", 1, 0, {OPERAND_NONE}},
+ /* Unary plus: push +stktop */
+ {"uminus", 1, 0, {OPERAND_NONE}},
+ /* Unary minus: push -stktop */
+ {"bitnot", 1, 0, {OPERAND_NONE}},
+ /* Bitwise not: push ~stktop */
+ {"not", 1, 0, {OPERAND_NONE}},
+ /* Logical not: push !stktop */
+ {"callBuiltinFunc1", 2, 1, {OPERAND_UINT1}},
+ /* Call builtin math function with index op1; any args are on stk */
+ {"callFunc1", 2, 1, {OPERAND_UINT1}},
+ /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */
+ {"tryCvtToNumeric", 1, 0, {OPERAND_NONE}},
+ /* Try converting stktop to first int then double if possible. */
+
+ {"break", 1, 0, {OPERAND_NONE}},
+ /* Abort closest enclosing loop; if none, return TCL_BREAK code. */
+ {"continue", 1, 0, {OPERAND_NONE}},
+ /* Skip to next iteration of closest enclosing loop; if none,
+ * return TCL_CONTINUE code. */
+
+ {"foreach_start4", 5, 1, {OPERAND_UINT4}},
+ /* Initialize execution of a foreach loop. Operand is aux data index
+ * of the ForeachInfo structure for the foreach command. */
+ {"foreach_step4", 5, 1, {OPERAND_UINT4}},
+ /* "Step" or begin next iteration of foreach loop. Push 0 if to
+ * terminate loop, else push 1. */
+
+ {"beginCatch4", 5, 1, {OPERAND_UINT4}},
+ /* Record start of catch with the operand's exception range index.
+ * Push the current stack depth onto a special catch stack. */
+ {"endCatch", 1, 0, {OPERAND_NONE}},
+ /* End of last catch. Pop the bytecode interpreter's catch stack. */
+ {"pushResult", 1, 0, {OPERAND_NONE}},
+ /* Push the interpreter's object result onto the stack. */
+ {"pushReturnCode", 1, 0, {OPERAND_NONE}},
+ /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as
+ * a new object onto the stack. */
+ {0}
+};
+
+/*
+ * The following table assigns a type to each character. Only types
+ * meaningful to Tcl parsing are represented here. The table is
+ * designed to be referenced with either signed or unsigned characters,
+ * so it has 384 entries. The first 128 entries correspond to negative
+ * character values, the next 256 correspond to positive character
+ * values. The last 128 entries are identical to the first 128. The
+ * table is always indexed with a 128-byte offset (the 128th entry
+ * corresponds to a 0 character value).
+ */
+
+unsigned char tclTypeTable[] = {
+ /*
+ * Negative character values, from -128 to -1:
+ */
+
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+
+ /*
+ * Positive character values, from 0-127:
+ */
+
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_SPACE, TCL_COMMAND_END, TCL_SPACE,
+ TCL_SPACE, TCL_SPACE, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_SPACE, TCL_NORMAL, TCL_QUOTE, TCL_NORMAL,
+ TCL_DOLLAR, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_COMMAND_END,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACKET,
+ TCL_BACKSLASH, TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACE,
+ TCL_NORMAL, TCL_CLOSE_BRACE, TCL_NORMAL, TCL_NORMAL,
+
+ /*
+ * Large unsigned character values, from 128-255:
+ */
+
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+};
+
+/*
+ * Prototypes for procedures defined later in this file:
+ */
+
+static void AdvanceToNextWord _ANSI_ARGS_((char *string,
+ CompileEnv *envPtr));
+static int CollectArgInfo _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, char *lastChar, int flags,
+ ArgInfo *argInfoPtr));
+static int CompileBraces _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, char *lastChar, int flags,
+ CompileEnv *envPtr));
+static int CompileCmdWordInline _ANSI_ARGS_((
+ Tcl_Interp *interp, char *string,
+ char *lastChar, int flags, CompileEnv *envPtr));
+static int CompileExprWord _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, char *lastChar, int flags,
+ CompileEnv *envPtr));
+static int CompileMultipartWord _ANSI_ARGS_((
+ Tcl_Interp *interp, char *string,
+ char *lastChar, int flags, CompileEnv *envPtr));
+static int CompileWord _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, char *lastChar, int flags,
+ CompileEnv *envPtr));
+static int CreateExceptionRange _ANSI_ARGS_((
+ ExceptionRangeType type, CompileEnv *envPtr));
+static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
+ Tcl_Obj *copyPtr));
+static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData));
+static void EnterCmdExtentData _ANSI_ARGS_((
+ CompileEnv *envPtr, int cmdNumber,
+ int numSrcChars, int numCodeBytes));
+static void EnterCmdStartData _ANSI_ARGS_((
+ CompileEnv *envPtr, int cmdNumber,
+ int srcOffset, int codeOffset));
+static void ExpandObjectArray _ANSI_ARGS_((CompileEnv *envPtr));
+static void FreeForeachInfo _ANSI_ARGS_((
+ ClientData clientData));
+static void FreeByteCodeInternalRep _ANSI_ARGS_((
+ Tcl_Obj *objPtr));
+static void FreeArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr));
+static void InitArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr));
+static int LookupCompiledLocal _ANSI_ARGS_((
+ char *name, int nameChars, int createIfNew,
+ int flagsIfCreated, Proc *procPtr));
+static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+static void UpdateStringOfByteCode _ANSI_ARGS_((Tcl_Obj *objPtr));
+
+/*
+ * The structure below defines the bytecode Tcl object type by
+ * means of procedures that can be invoked by generic object code.
+ */
+
+Tcl_ObjType tclByteCodeType = {
+ "bytecode", /* name */
+ FreeByteCodeInternalRep, /* freeIntRepProc */
+ DupByteCodeInternalRep, /* dupIntRepProc */
+ UpdateStringOfByteCode, /* updateStringProc */
+ SetByteCodeFromAny /* setFromAnyProc */
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintByteCodeObj --
+ *
+ * This procedure prints ("disassembles") the instructions of a
+ * bytecode object to stdout.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclPrintByteCodeObj(interp, objPtr)
+ Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */
+ Tcl_Obj *objPtr; /* The bytecode object to disassemble. */
+{
+ ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ Proc *procPtr;
+ CmdLocation *mapPtr;
+ ExceptionRange *excRangeArrayPtr;
+ unsigned char *codeStart, *codeLimit, *pc, *start;
+ int numCmds, numRanges, cmd, maxChars, i;
+ char *source;
+
+ if (codePtr->refCount <= 0) {
+ return; /* already freed */
+ }
+
+ codeStart = codePtr->codeStart;
+ codeLimit = (codeStart + codePtr->numCodeBytes);
+ source = codePtr->source;
+ procPtr = codePtr->procPtr;
+ numCmds = codePtr->numCommands;
+ numRanges = codePtr->numExcRanges;
+ mapPtr = codePtr->cmdMapPtr;
+ excRangeArrayPtr = codePtr->excRangeArrayPtr;
+
+ fprintf(stdout, "\nByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x, interp epoch %u\n",
+ (unsigned int) codePtr, codePtr->refCount,
+ codePtr->compileEpoch, (unsigned int) codePtr->iPtr,
+ codePtr->iPtr->compileEpoch);
+ if (procPtr != NULL) {
+ int numCompiledLocals = procPtr->numCompiledLocals;
+ fprintf(stdout,
+ " Proc 0x%x, ref ct=%d, %d args, %d compiled locals\n",
+ (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs,
+ numCompiledLocals);
+ if (numCompiledLocals > 0) {
+ CompiledLocal *localPtr = procPtr->firstLocalPtr;
+ for (i = 0; i < numCompiledLocals; i++) {
+ fprintf(stdout, " %d: frame index=%d, flags=0x%x%s%s",
+ i, localPtr->frameIndex, localPtr->flags,
+ (localPtr->isArg? ", arg" : ""),
+ (localPtr->isTemp? ", temp" : ""));
+ if (localPtr->isTemp) {
+ fprintf(stdout, "\n");
+ } else {
+ fprintf(stdout, ", name=\"%s\"\n", localPtr->name);
+ }
+ localPtr = localPtr->nextPtr;
+ }
+ }
+ }
+ fprintf(stdout, " Source: ");
+ TclPrintSource(stdout, source, TclMin(codePtr->numSrcChars, 70));
+ fprintf(stdout, "\n Chars=%d, bytes=%u, objs=%u, stk depth=%u, exc depth=%d, aux items=%d\n",
+ codePtr->numSrcChars, codePtr->numCodeBytes,
+ codePtr->numObjects, codePtr->maxStackDepth,
+ codePtr->maxExcRangeDepth, codePtr->numAuxDataItems);
+
+ /*
+ * If there were no commands (e.g., an expression or an empty string
+ * was compiled), just print all instructions.
+ */
+
+ if (numCmds == 0) {
+ start = codeStart;
+ pc = start;
+ while (pc < codeLimit) {
+ fprintf(stdout, " ");
+ pc += TclPrintInstruction(codePtr, pc);
+ }
+ return;
+ }
+
+ /*
+ * Print table giving the source and object locations for each command.
+ */
+
+ fprintf(stdout, " Commands=%d\n", numCmds);
+ for (i = 0; i < numCmds; i++) {
+ fprintf(stdout, " %d: source=%d-%d, code=%d-%d\n",
+ (i+1), mapPtr[i].srcOffset,
+ (mapPtr[i].srcOffset + mapPtr[i].numSrcChars - 1),
+ mapPtr[i].codeOffset,
+ (mapPtr[i].codeOffset + mapPtr[i].numCodeBytes - 1));
+ }
+
+ /*
+ * Print the ExceptionRange array.
+ */
+
+ fprintf(stdout, " Exception ranges=%d\n", numRanges);
+ for (i = 0; i < numRanges; i++) {
+ ExceptionRange *rangePtr = &(excRangeArrayPtr[i]);
+ fprintf(stdout, " %d: level=%d, type=%s, pc range=%d-%d, ",
+ i, rangePtr->nestingLevel,
+ ((rangePtr->type == LOOP_EXCEPTION_RANGE)? "loop" : "catch"),
+ rangePtr->codeOffset,
+ (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
+ switch (rangePtr->type) {
+ case LOOP_EXCEPTION_RANGE:
+ fprintf(stdout, "continue=%d, break=%d\n",
+ rangePtr->continueOffset, rangePtr->breakOffset);
+ break;
+ case CATCH_EXCEPTION_RANGE:
+ fprintf(stdout, "catch=%d\n", rangePtr->catchOffset);
+ break;
+ default:
+ fprintf(stdout, "unrecognized ExceptionRange type %d\n",
+ rangePtr->type);
+ }
+ }
+
+ /*
+ * Print each instruction. If the instruction corresponds to the start
+ * of a command, print the command's source.
+ */
+
+ start = codeStart;
+ cmd = 0;
+ pc = start;
+ while (pc < codeLimit) {
+ int pcOffset = (pc - start);
+ while ((cmd < numCmds) && (pcOffset >= mapPtr[cmd].codeOffset)) {
+ /*
+ * The start of the command with index cmd.
+ */
+
+ maxChars = TclMin(mapPtr[cmd].numSrcChars, 70);
+ fprintf(stdout, " Command %d: ", (cmd+1));
+ TclPrintSource(stdout, (source + mapPtr[cmd].srcOffset),
+ maxChars);
+ fprintf(stdout, "\n");
+ cmd++;
+ }
+ fprintf(stdout, " ");
+ pc += TclPrintInstruction(codePtr, pc);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintInstruction --
+ *
+ * This procedure prints ("disassembles") one instruction from a
+ * bytecode object to stdout.
+ *
+ * Results:
+ * Returns the length in bytes of the current instruiction.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclPrintInstruction(codePtr, pc)
+ ByteCode* codePtr; /* Bytecode containing the instruction. */
+ unsigned char *pc; /* Points to first byte of instruction. */
+{
+ Proc *procPtr = codePtr->procPtr;
+ unsigned char opCode = *pc;
+ register InstructionDesc *instDesc = &instructionTable[opCode];
+ unsigned char *codeStart = codePtr->codeStart;
+ unsigned int pcOffset = (pc - codeStart);
+ int opnd, elemLen, i, j;
+ Tcl_Obj *elemPtr;
+ char *string;
+
+ fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
+ for (i = 0; i < instDesc->numOperands; i++) {
+ switch (instDesc->opTypes[i]) {
+ case OPERAND_INT1:
+ opnd = TclGetInt1AtPc(pc+1+i);
+ if ((i == 0) && ((opCode == INST_JUMP1)
+ || (opCode == INST_JUMP_TRUE1)
+ || (opCode == INST_JUMP_FALSE1))) {
+ fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
+ } else {
+ fprintf(stdout, "%d", opnd);
+ }
+ break;
+ case OPERAND_INT4:
+ opnd = TclGetInt4AtPc(pc+1+i);
+ if ((i == 0) && ((opCode == INST_JUMP4)
+ || (opCode == INST_JUMP_TRUE4)
+ || (opCode == INST_JUMP_FALSE4))) {
+ fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
+ } else {
+ fprintf(stdout, "%d", opnd);
+ }
+ break;
+ case OPERAND_UINT1:
+ opnd = TclGetUInt1AtPc(pc+1+i);
+ if ((i == 0) && (opCode == INST_PUSH1)) {
+ elemPtr = codePtr->objArrayPtr[opnd];
+ string = Tcl_GetStringFromObj(elemPtr, &elemLen);
+ fprintf(stdout, "%u # ", (unsigned int) opnd);
+ TclPrintSource(stdout, string, TclMin(elemLen, 40));
+ } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1)
+ || (opCode == INST_LOAD_ARRAY1)
+ || (opCode == INST_STORE_SCALAR1)
+ || (opCode == INST_STORE_ARRAY1))) {
+ int localCt = procPtr->numCompiledLocals;
+ CompiledLocal *localPtr = procPtr->firstLocalPtr;
+ if (opnd >= localCt) {
+ panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
+ (unsigned int) opnd, localCt);
+ return instDesc->numBytes;
+ }
+ for (j = 0; j < opnd; j++) {
+ localPtr = localPtr->nextPtr;
+ }
+ if (localPtr->isTemp) {
+ fprintf(stdout, "%u # temp var %u",
+ (unsigned int) opnd, (unsigned int) opnd);
+ } else {
+ fprintf(stdout, "%u # var ", (unsigned int) opnd);
+ TclPrintSource(stdout, localPtr->name, 40);
+ }
+ } else {
+ fprintf(stdout, "%u ", (unsigned int) opnd);
+ }
+ break;
+ case OPERAND_UINT4:
+ opnd = TclGetUInt4AtPc(pc+1+i);
+ if (opCode == INST_PUSH4) {
+ elemPtr = codePtr->objArrayPtr[opnd];
+ string = Tcl_GetStringFromObj(elemPtr, &elemLen);
+ fprintf(stdout, "%u # ", opnd);
+ TclPrintSource(stdout, string, TclMin(elemLen, 40));
+ } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4)
+ || (opCode == INST_LOAD_ARRAY4)
+ || (opCode == INST_STORE_SCALAR4)
+ || (opCode == INST_STORE_ARRAY4))) {
+ int localCt = procPtr->numCompiledLocals;
+ CompiledLocal *localPtr = procPtr->firstLocalPtr;
+ if (opnd >= localCt) {
+ panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
+ (unsigned int) opnd, localCt);
+ return instDesc->numBytes;
+ }
+ for (j = 0; j < opnd; j++) {
+ localPtr = localPtr->nextPtr;
+ }
+ if (localPtr->isTemp) {
+ fprintf(stdout, "%u # temp var %u",
+ (unsigned int) opnd, (unsigned int) opnd);
+ } else {
+ fprintf(stdout, "%u # var ", (unsigned int) opnd);
+ TclPrintSource(stdout, localPtr->name, 40);
+ }
+ } else {
+ fprintf(stdout, "%u ", (unsigned int) opnd);
+ }
+ break;
+ case OPERAND_NONE:
+ default:
+ break;
+ }
+ }
+ fprintf(stdout, "\n");
+ return instDesc->numBytes;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintSource --
+ *
+ * This procedure prints up to a specified number of characters from
+ * the argument string to a specified file. It tries to produce legible
+ * output by adding backslashes as necessary.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Outputs characters to the specified file.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclPrintSource(outFile, string, maxChars)
+ FILE *outFile; /* The file to print the source to. */
+ char *string; /* The string to print. */
+ int maxChars; /* Maximum number of chars to print. */
+{
+ register char *p;
+ register int i = 0;
+
+ if (string == NULL) {
+ fprintf(outFile, "\"\"");
+ return;
+ }
+
+ fprintf(outFile, "\"");
+ p = string;
+ for (; (*p != '\0') && (i < maxChars); p++, i++) {
+ switch (*p) {
+ case '"':
+ fprintf(outFile, "\\\"");
+ continue;
+ case '\f':
+ fprintf(outFile, "\\f");
+ continue;
+ case '\n':
+ fprintf(outFile, "\\n");
+ continue;
+ case '\r':
+ fprintf(outFile, "\\r");
+ continue;
+ case '\t':
+ fprintf(outFile, "\\t");
+ continue;
+ case '\v':
+ fprintf(outFile, "\\v");
+ continue;
+ default:
+ fprintf(outFile, "%c", *p);
+ continue;
+ }
+ }
+ fprintf(outFile, "\"");
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeByteCodeInternalRep --
+ *
+ * Part of the bytecode Tcl object type implementation. Frees the
+ * storage associated with a bytecode object's internal representation
+ * unless its code is actively being executed.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The bytecode object's internal rep is marked invalid and its
+ * code gets freed unless the code is actively being executed.
+ * In that case the cleanup is delayed until the last execution
+ * of the code completes.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeByteCodeInternalRep(objPtr)
+ register Tcl_Obj *objPtr; /* Object whose internal rep to free. */
+{
+ register ByteCode *codePtr =
+ (ByteCode *) objPtr->internalRep.otherValuePtr;
+
+ codePtr->refCount--;
+ if (codePtr->refCount <= 0) {
+ TclCleanupByteCode(codePtr);
+ }
+ objPtr->typePtr = NULL;
+ objPtr->internalRep.otherValuePtr = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CleanupByteCode --
+ *
+ * This procedure does all the real work of freeing up a bytecode
+ * object's ByteCode structure. It's called only when the structure's
+ * reference count becomes zero.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees objPtr's bytecode internal representation and sets
+ * its type and objPtr->internalRep.otherValuePtr NULL. Also
+ * decrements the ref counts on each object in its object array,
+ * and frees its auxiliary data items.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclCleanupByteCode(codePtr)
+ ByteCode *codePtr; /* ByteCode to free. */
+{
+ Tcl_Obj **objArrayPtr = codePtr->objArrayPtr;
+ int numObjects = codePtr->numObjects;
+ int numAuxDataItems = codePtr->numAuxDataItems;
+ register AuxData *auxDataPtr;
+ register Tcl_Obj *elemPtr;
+ register int i;
+
+ /*
+ * A single heap object holds the ByteCode structure and its code,
+ * object, command location, and auxiliary data arrays. This means we
+ * only need to 1) decrement the ref counts on the objects in its
+ * object array, 2) call the free procs for the auxiliary data items,
+ * and 3) free the ByteCode structure's heap object.
+ */
+
+ for (i = 0; i < numObjects; i++) {
+ elemPtr = objArrayPtr[i];
+ TclDecrRefCount(elemPtr);
+ }
+
+ auxDataPtr = codePtr->auxDataArrayPtr;
+ for (i = 0; i < numAuxDataItems; i++) {
+ if (auxDataPtr->freeProc != NULL) {
+ auxDataPtr->freeProc(auxDataPtr->clientData);
+ }
+ auxDataPtr++;
+ }
+
+ ckfree((char *) codePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupByteCodeInternalRep --
+ *
+ * Part of the bytecode Tcl object type implementation. Initializes the
+ * internal representation of a bytecode Tcl_Obj to a copy of the
+ * internal representation of an existing bytecode object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * "copyPtr"s internal rep is set to the bytecode sequence
+ * corresponding to "srcPtr"s internal rep. Ref counts for objects
+ * in the existing bytecode object's object array are incremented
+ * the bytecode copy now also refers to them.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupByteCodeInternalRep(srcPtr, copyPtr)
+ Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
+ Tcl_Obj *copyPtr; /* Object with internal rep to set. */
+{
+ ByteCode *codePtr = (ByteCode *) srcPtr->internalRep.otherValuePtr;
+ register ByteCode *dupPtr;
+ int codeBytes = codePtr->numCodeBytes;
+ int numObjects = codePtr->numObjects;
+ int numAuxDataItems = codePtr->numAuxDataItems;
+ register AuxData *srcAuxDataPtr, *dupAuxDataPtr;
+ size_t objArrayBytes, rangeArrayBytes, cmdLocBytes, auxDataBytes;
+ register size_t size;
+ register char *p;
+ int i;
+
+ /*
+ * Allocate a single heap object to hold the copied ByteCode structure
+ * and its code, object, command location, and auxiliary data arrays.
+ */
+
+ objArrayBytes = numObjects * sizeof(Tcl_Obj *);
+ rangeArrayBytes = (codePtr->numExcRanges * sizeof(ExceptionRange));
+ cmdLocBytes = codePtr->numCommands * sizeof(CmdLocation);
+ auxDataBytes = numAuxDataItems * sizeof(AuxData);
+
+ size = TCL_ALIGN(sizeof(ByteCode));
+ size += TCL_ALIGN(codeBytes);
+ size += TCL_ALIGN(objArrayBytes);
+ size += TCL_ALIGN(rangeArrayBytes);
+ size += TCL_ALIGN(cmdLocBytes);
+ size += TCL_ALIGN(auxDataBytes);
+
+ p = (char *) ckalloc(size);
+ dupPtr = (ByteCode *) p;
+ memcpy((VOID *) dupPtr, (VOID *) codePtr, size);
+
+ p += TCL_ALIGN(sizeof(ByteCode));
+ dupPtr->codeStart = (unsigned char *) p;
+
+ p += TCL_ALIGN(codeBytes);
+ dupPtr->objArrayPtr = (Tcl_Obj **) p;
+
+ p += TCL_ALIGN(objArrayBytes);
+ dupPtr->excRangeArrayPtr = (ExceptionRange *) p;
+
+ p += TCL_ALIGN(rangeArrayBytes);
+ dupPtr->cmdMapPtr = (CmdLocation *) p;
+
+ p += TCL_ALIGN(cmdLocBytes);
+ dupPtr->auxDataArrayPtr = (AuxData *) p;
+
+ /*
+ * Increment the ref counts for objects in the object array since we are
+ * creating new references for them in the copied object array.
+ */
+
+ for (i = 0; i < numObjects; i++) {
+ Tcl_IncrRefCount(dupPtr->objArrayPtr[i]);
+ }
+
+ /*
+ * Duplicate any auxiliary data items.
+ */
+
+ srcAuxDataPtr = codePtr->auxDataArrayPtr;
+ dupAuxDataPtr = dupPtr->auxDataArrayPtr;
+ for (i = 0; i < numAuxDataItems; i++) {
+ if (srcAuxDataPtr->dupProc != NULL) {
+ dupAuxDataPtr->clientData =
+ srcAuxDataPtr->dupProc(srcAuxDataPtr->clientData);
+ } else {
+ dupAuxDataPtr->clientData = srcAuxDataPtr->clientData;
+ }
+ srcAuxDataPtr++;
+ dupAuxDataPtr++;
+ }
+
+ copyPtr->internalRep.otherValuePtr = (VOID *) dupPtr;
+ copyPtr->typePtr = &tclByteCodeType;
+}
+
+/*
+ *-----------------------------------------------------------------------
+ *
+ * SetByteCodeFromAny --
+ *
+ * Part of the bytecode Tcl object type implementation. Attempts to
+ * generate an byte code internal form for the Tcl object "objPtr" by
+ * compiling its string representation.
+ *
+ * Results:
+ * The return value is a standard Tcl object result. If an error occurs
+ * during compilation, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
+ *
+ * Side effects:
+ * Frees the old internal representation. If no error occurs, then the
+ * compiled code is stored as "objPtr"s bytecode representation.
+ * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
+ * used to trace compilations.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetByteCodeFromAny(interp, objPtr)
+ Tcl_Interp *interp; /* The interpreter for which the code is
+ * compiled. */
+ Tcl_Obj *objPtr; /* The object to convert. */
+{
+ Interp *iPtr = (Interp *) interp;
+ char *string;
+ CompileEnv compEnv; /* Compilation environment structure
+ * allocated in frame. */
+ AuxData *auxDataPtr;
+ register int i;
+ int length, result;
+
+ if (!traceInitialized) {
+ if (Tcl_LinkVar(interp, "tcl_traceCompile",
+ (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
+ panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
+ }
+ traceInitialized = 1;
+ }
+
+#ifdef TCL_COMPILE_STATS
+ tclNumCompilations++;
+#endif /* TCL_COMPILE_STATS */
+
+ string = Tcl_GetStringFromObj(objPtr, &length);
+ TclInitCompileEnv(interp, &compEnv, string);
+ result = TclCompileString(interp, string, string+length,
+ iPtr->evalFlags, &compEnv);
+ if (result == TCL_OK) {
+ /*
+ * Add a "done" instruction at the end of the instruction sequence.
+ */
+
+ TclEmitOpcode(INST_DONE, &compEnv);
+
+ /*
+ * Convert the object to a ByteCode object.
+ */
+
+ TclInitByteCodeObj(objPtr, &compEnv);
+ } else {
+ /*
+ * Compilation errors. Decrement the ref counts on any objects in
+ * the object array and free any aux data items prior to freeing
+ * the compilation environment.
+ */
+
+ for (i = 0; i < compEnv.objArrayNext; i++) {
+ Tcl_Obj *elemPtr = compEnv.objArrayPtr[i];
+ Tcl_DecrRefCount(elemPtr);
+ }
+
+ auxDataPtr = compEnv.auxDataArrayPtr;
+ for (i = 0; i < compEnv.auxDataArrayNext; i++) {
+ if (auxDataPtr->freeProc != NULL) {
+ auxDataPtr->freeProc(auxDataPtr->clientData);
+ }
+ auxDataPtr++;
+ }
+ }
+ TclFreeCompileEnv(&compEnv);
+
+ if (result == TCL_OK) {
+ if (tclTraceCompile == 2) {
+ TclPrintByteCodeObj(interp, objPtr);
+ }
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfByteCode --
+ *
+ * Part of the bytecode Tcl object type implementation. Called to
+ * update the string representation for a byte code object.
+ * Note: This procedure does not free an existing old string rep
+ * so storage will be lost if this has not already been done.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Generates a panic.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfByteCode(objPtr)
+ register Tcl_Obj *objPtr; /* ByteCode object with string rep that
+ * needs updating. */
+{
+ /*
+ * This procedure is never invoked since the internal representation of
+ * a bytecode object is never modified.
+ */
+
+ panic("UpdateStringOfByteCode should never be called.");
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitCompileEnv --
+ *
+ * Initializes a CompileEnv compilation environment structure for the
+ * compilation of a string in an interpreter.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The CompileEnv structure is initialized.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclInitCompileEnv(interp, envPtr, string)
+ Tcl_Interp *interp; /* The interpreter for which a CompileEnv
+ * structure is initialized. */
+ register CompileEnv *envPtr; /* Points to the CompileEnv structure to
+ * initialize. */
+ char *string; /* The source string to be compiled. */
+{
+ Interp *iPtr = (Interp *) interp;
+
+ envPtr->iPtr = iPtr;
+ envPtr->source = string;
+ envPtr->procPtr = iPtr->compiledProcPtr;
+ envPtr->numCommands = 0;
+ envPtr->excRangeDepth = 0;
+ envPtr->maxExcRangeDepth = 0;
+ envPtr->maxStackDepth = 0;
+ Tcl_InitHashTable(&(envPtr->objTable), TCL_STRING_KEYS);
+ envPtr->pushSimpleWords = 1;
+ envPtr->wordIsSimple = 0;
+ envPtr->numSimpleWordChars = 0;
+ envPtr->exprIsJustVarRef = 0;
+ envPtr->termOffset = 0;
+
+ envPtr->codeStart = envPtr->staticCodeSpace;
+ envPtr->codeNext = envPtr->codeStart;
+ envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES);
+ envPtr->mallocedCodeArray = 0;
+
+ envPtr->objArrayPtr = envPtr->staticObjArraySpace;
+ envPtr->objArrayNext = 0;
+ envPtr->objArrayEnd = COMPILEENV_INIT_NUM_OBJECTS;
+ envPtr->mallocedObjArray = 0;
+
+ envPtr->excRangeArrayPtr = envPtr->staticExcRangeArraySpace;
+ envPtr->excRangeArrayNext = 0;
+ envPtr->excRangeArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
+ envPtr->mallocedExcRangeArray = 0;
+
+ envPtr->cmdMapPtr = envPtr->staticCmdMapSpace;
+ envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
+ envPtr->mallocedCmdMap = 0;
+
+ envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
+ envPtr->auxDataArrayNext = 0;
+ envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE;
+ envPtr->mallocedAuxDataArray = 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFreeCompileEnv --
+ *
+ * Free the storage allocated in a CompileEnv compilation environment
+ * structure.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Allocated storage in the CompileEnv structure is freed. Note that
+ * ref counts for Tcl objects in its object table are not decremented.
+ * In addition, any storage referenced by any auxiliary data items
+ * in the CompileEnv structure are not freed either. The expectation
+ * is that when compilation is successful, "ownership" (i.e., the
+ * pointers to) these objects and aux data items will just be handed
+ * over to the corresponding ByteCode structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFreeCompileEnv(envPtr)
+ register CompileEnv *envPtr; /* Points to the CompileEnv structure. */
+{
+ Tcl_DeleteHashTable(&(envPtr->objTable));
+ if (envPtr->mallocedCodeArray) {
+ ckfree((char *) envPtr->codeStart);
+ }
+ if (envPtr->mallocedObjArray) {
+ ckfree((char *) envPtr->objArrayPtr);
+ }
+ if (envPtr->mallocedExcRangeArray) {
+ ckfree((char *) envPtr->excRangeArrayPtr);
+ }
+ if (envPtr->mallocedCmdMap) {
+ ckfree((char *) envPtr->cmdMapPtr);
+ }
+ if (envPtr->mallocedAuxDataArray) {
+ ckfree((char *) envPtr->auxDataArrayPtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitByteCodeObj --
+ *
+ * Create a ByteCode structure and initialize it from a CompileEnv
+ * compilation environment structure. The ByteCode structure is
+ * smaller and contains just that information needed to execute
+ * the bytecode instructions resulting from compiling a Tcl script.
+ * The resulting structure is placed in the specified object.
+ *
+ * Results:
+ * A newly constructed ByteCode object is stored in the internal
+ * representation of the objPtr.
+ *
+ * Side effects:
+ * A single heap object is allocated to hold the new ByteCode structure
+ * and its code, object, command location, and aux data arrays. Note
+ * that "ownership" (i.e., the pointers to) the Tcl objects and aux
+ * data items will be handed over to the new ByteCode structure from
+ * the CompileEnv structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclInitByteCodeObj(objPtr, envPtr)
+ Tcl_Obj *objPtr; /* Points object that should be
+ * initialized, and whose string rep
+ * contains the source code. */
+ register CompileEnv *envPtr; /* Points to the CompileEnv structure from
+ * which to create a ByteCode structure. */
+{
+ register ByteCode *codePtr;
+ size_t codeBytes, objArrayBytes, rangeArrayBytes, cmdLocBytes;
+ size_t auxDataArrayBytes;
+ register size_t size;
+ register char *p;
+
+ codeBytes = envPtr->codeNext - envPtr->codeStart;
+ objArrayBytes = envPtr->objArrayNext * sizeof(Tcl_Obj *);
+ rangeArrayBytes = (envPtr->excRangeArrayNext * sizeof(ExceptionRange));
+ cmdLocBytes = envPtr->numCommands * sizeof(CmdLocation);
+ auxDataArrayBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
+
+ size = TCL_ALIGN(sizeof(ByteCode));
+ size += TCL_ALIGN(codeBytes);
+ size += TCL_ALIGN(objArrayBytes);
+ size += TCL_ALIGN(rangeArrayBytes);
+ size += TCL_ALIGN(cmdLocBytes);
+ size += TCL_ALIGN(auxDataArrayBytes);
+
+ p = (char *) ckalloc(size);
+ codePtr = (ByteCode *) p;
+ codePtr->iPtr = envPtr->iPtr;
+ codePtr->compileEpoch = envPtr->iPtr->compileEpoch;
+ codePtr->refCount = 1;
+ codePtr->source = envPtr->source;
+ codePtr->procPtr = envPtr->procPtr;
+ codePtr->numCommands = envPtr->numCommands;
+ codePtr->numSrcChars = envPtr->termOffset;
+ codePtr->numCodeBytes = codeBytes;
+ codePtr->numObjects = envPtr->objArrayNext;
+ codePtr->numExcRanges = envPtr->excRangeArrayNext;
+ codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
+ codePtr->maxExcRangeDepth = envPtr->maxExcRangeDepth;
+ codePtr->maxStackDepth = envPtr->maxStackDepth;
+
+ p += TCL_ALIGN(sizeof(ByteCode));
+ codePtr->codeStart = (unsigned char *) p;
+ memcpy((VOID *) p, (VOID *) envPtr->codeStart, codeBytes);
+
+ p += TCL_ALIGN(codeBytes);
+ codePtr->objArrayPtr = (Tcl_Obj **) p;
+ memcpy((VOID *) p, (VOID *) envPtr->objArrayPtr, objArrayBytes);
+
+ p += TCL_ALIGN(objArrayBytes);
+ codePtr->excRangeArrayPtr = (ExceptionRange *) p;
+ memcpy((VOID *) p, (VOID *) envPtr->excRangeArrayPtr, rangeArrayBytes);
+
+ p += TCL_ALIGN(rangeArrayBytes);
+ codePtr->cmdMapPtr = (CmdLocation *) p;
+ memcpy((VOID *) p, (VOID *) envPtr->cmdMapPtr, cmdLocBytes);
+
+ p += TCL_ALIGN(cmdLocBytes);
+ codePtr->auxDataArrayPtr = (AuxData *) p;
+ memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr, auxDataArrayBytes);
+
+ /*
+ * Free the old internal rep then convert the object to a
+ * bytecode object by making its internal rep point to the just
+ * compiled ByteCode.
+ */
+
+ if ((objPtr->typePtr != NULL) &&
+ (objPtr->typePtr->freeIntRepProc != NULL)) {
+ objPtr->typePtr->freeIntRepProc(objPtr);
+ }
+ objPtr->internalRep.otherValuePtr = (VOID *) codePtr;
+ objPtr->typePtr = &tclByteCodeType;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileString --
+ *
+ * Compile a Tcl script in a null-terminated binary string.
+ *
+ * Results:
+ * The return value is TCL_OK on a successful compilation and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * envPtr->termOffset and interp->termOffset are filled in with the
+ * offset of the character in the string just after the last one
+ * successfully processed; this might be the offset of the ']' (if
+ * flags & TCL_BRACKET_TERM), or the offset of the '\0' at the end of
+ * the string. Also updates envPtr->maxStackDepth with the maximum
+ * number of stack elements needed to execute the string's commands.
+ *
+ * Side effects:
+ * Adds instructions to envPtr to evaluate the string at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileString(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* The source string to compile. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Interp *iPtr = (Interp *) interp;
+ register char *src = string;/* Points to current source char. */
+ register char c = *src; /* The current char. */
+ register int type; /* Current char's CHAR_TYPE type. */
+ char termChar = (char)((flags & TCL_BRACKET_TERM)? ']' : '\0');
+ /* Return when this character is found
+ * (either ']' or '\0'). Zero means newlines
+ * terminate cmds. */
+ int isFirstCmd = 1; /* 1 if compiling the first cmd. */
+ char *cmdSrcStart = NULL; /* Points to first non-blank char in each
+ * command. Initialized to avoid compiler
+ * warning. */
+ int cmdIndex = -1; /* The index of the current command in the
+ * compilation environment's command
+ * location table. Initialized to avoid
+ * compiler warning. */
+ int cmdCodeOffset = -1; /* Offset of first byte of current command's
+ * code. Initialized to avoid compiler
+ * warning. */
+ int cmdCodeBytes; /* Number of code bytes for current
+ * command. */
+ int cmdWords; /* Number of words in current command. */
+ Tcl_Command cmd; /* Used to search for commands. */
+ Command *cmdPtr; /* Points to command's Command structure if
+ * first word is simple and command was
+ * found; else NULL. */
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute all cmds. */
+ char *termPtr; /* Points to char that terminated word. */
+ char savedChar; /* Holds the character from string
+ * termporarily replaced by a null character
+ * during processing of words. */
+ int objIndex = -1; /* The object array index for a pushed
+ * object holding a word or word part
+ * Initialized to avoid compiler warning. */
+ unsigned char *entryCodeNext = envPtr->codeNext;
+ /* Value of envPtr's current instruction
+ * pointer at entry. Used to tell if any
+ * instructions generated. */
+ char *ellipsis = ""; /* Used to set errorInfo variable; "..."
+ * indicates that not all of offending
+ * command is included in errorInfo. ""
+ * means that the command is all there. */
+ Tcl_Obj *objPtr;
+ int numChars;
+ int result = TCL_OK;
+ int savePushSimpleWords = envPtr->pushSimpleWords;
+
+ /*
+ * commands: command {(';' | '\n') command}
+ */
+
+ while ((src != lastChar) && (c != termChar)) {
+ /*
+ * Skip white space, semicolons, backslash-newlines (treated as
+ * spaces), and comments before command.
+ */
+
+ type = CHAR_TYPE(src, lastChar);
+ while ((type & (TCL_SPACE | TCL_BACKSLASH))
+ || (c == '\n') || (c == ';')) {
+ if (type == TCL_BACKSLASH) {
+ if (src[1] == '\n') {
+ src += 2;
+ } else {
+ break; /* no longer white space */
+ }
+ } else {
+ src++;
+ }
+ c = *src;
+ type = CHAR_TYPE(src, lastChar);
+ }
+
+ if (c == '#') {
+ while (src != lastChar) {
+ if (c == '\\') {
+ int numRead;
+ Tcl_Backslash(src, &numRead);
+ src += numRead;
+ } else if (c == '\n') {
+ src++;
+ c = *src;
+ envPtr->termOffset = (src - string);
+ break;
+ } else {
+ src++;
+ }
+ c = *src;
+ }
+ continue; /* end of comment, restart outer command loop */
+ }
+
+ /*
+ * Compile one command: zero or more words terminated by a '\n',
+ * ';', ']' (if command is terminated by close bracket), or
+ * the end of string.
+ *
+ * command: word*
+ */
+
+ type = CHAR_TYPE(src, lastChar);
+ if ((type == TCL_COMMAND_END)
+ && ((c != ']') || (flags & TCL_BRACKET_TERM))) {
+ continue; /* ignore empty command; restart outer cmd loop */
+ }
+
+ /*
+ * If not the first command, discard the previous command's result.
+ */
+
+ if (!isFirstCmd) {
+ TclEmitOpcode(INST_POP, envPtr);
+ if (!(flags & TCL_BRACKET_TERM)) {
+ /*
+ * We are compiling a top level command. Update the number
+ * of code bytes for the last command to account for the pop
+ * instruction we just emitted.
+ */
+
+ int lastCmdIndex = (envPtr->numCommands - 1);
+ cmdCodeBytes =
+ (envPtr->codeNext - envPtr->codeStart - cmdCodeOffset);
+ (envPtr->cmdMapPtr[lastCmdIndex]).numCodeBytes =
+ cmdCodeBytes;
+ }
+ }
+
+ /*
+ * Compile the words of the command. Process the first word
+ * specially, since it is the name of a command. If it is a "simple"
+ * string (just a sequence of characters), look it up in the table
+ * of compilation procedures. If a word other than the first is
+ * simple and represents an integer whose formatted representation
+ * is the same as the word, just push an integer object. Also record
+ * starting source and object information for the command if we are
+ * at the top level (i.e. we were called directly from
+ * SetByteCodeFromAny and are not compiling a substring enclosed in
+ * square brackets).
+ */
+
+ cmdSrcStart = src;
+ cmdCodeOffset = (envPtr->codeNext - envPtr->codeStart);
+ cmdWords = 0;
+ if (!(flags & TCL_BRACKET_TERM)) {
+ envPtr->numCommands++;
+ cmdIndex = (envPtr->numCommands - 1);
+ EnterCmdStartData(envPtr, cmdIndex,
+ (cmdSrcStart - envPtr->source), cmdCodeOffset);
+
+ if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
+ /*
+ * Display a line summarizing the top level command we
+ * are about to compile.
+ */
+
+ char *p = cmdSrcStart;
+ int numChars;
+ char *ellipsis = "";
+
+ while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)
+ || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) {
+ p++;
+ }
+ numChars = (p - cmdSrcStart);
+ if (numChars > 60) {
+ numChars = 60;
+ ellipsis = " ...";
+ } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) {
+ ellipsis = " ...";
+ }
+ fprintf(stdout, "Compiling: %.*s%s\n",
+ numChars, cmdSrcStart, ellipsis);
+ }
+ }
+
+ while ((type != TCL_COMMAND_END)
+ || ((c == ']') && !(flags & TCL_BRACKET_TERM))) {
+ /*
+ * Skip any leading white space at the start of a word. Note
+ * that a backslash-newline is treated as a space.
+ */
+
+ while (type & (TCL_SPACE | TCL_BACKSLASH)) {
+ if (type == TCL_BACKSLASH) {
+ if (src[1] == '\n') {
+ src += 2;
+ } else {
+ break; /* no longer white space */
+ }
+ } else {
+ src++;
+ }
+ c = *src;
+ type = CHAR_TYPE(src, lastChar);
+ }
+ if ((type == TCL_COMMAND_END)
+ && ((c != ']') || (flags & TCL_BRACKET_TERM))) {
+ break; /* no words remain for command. */
+ }
+
+ /*
+ * Compile one word. We use an inline version of CompileWord to
+ * avoid an extra procedure call.
+ */
+
+ envPtr->pushSimpleWords = 0; /* we will handle simple words */
+ if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
+ src++; /* advance over the " or { */
+ if (type == TCL_QUOTE) {
+ result = TclCompileQuotes(interp, src, lastChar,
+ '"', flags, envPtr);
+ } else {
+ result = CompileBraces(interp, src, lastChar,
+ flags, envPtr);
+ }
+ termPtr = (src + envPtr->termOffset);
+ if (result != TCL_OK) {
+ src = termPtr;
+ goto done;
+ }
+
+ /*
+ * Make sure terminating character of the quoted or braced
+ * string is the end of word.
+ */
+
+ c = *termPtr;
+ if ((c == '\\') && (*(termPtr+1) == '\n')) {
+ /*
+ * Line is continued on next line; the backslash-
+ * newline turns into space, which terminates the word.
+ */
+ } else {
+ type = CHAR_TYPE(termPtr, lastChar);
+ if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) {
+ Tcl_ResetResult(interp);
+ if (*(src-1) == '"') {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "extra characters after close-quote", -1);
+ } else {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "extra characters after close-brace", -1);
+ }
+ result = TCL_ERROR;
+ }
+ }
+ } else {
+ result = CompileMultipartWord(interp, src, lastChar,
+ flags, envPtr);
+ termPtr = (src + envPtr->termOffset);
+ }
+ if (result != TCL_OK) {
+ ellipsis = "...";
+ src = termPtr;
+ goto done;
+ }
+
+ if (envPtr->wordIsSimple) {
+ /*
+ * A simple word. Temporarily replace the terminating
+ * character with a null character.
+ */
+
+ numChars = envPtr->numSimpleWordChars;
+ savedChar = src[numChars];
+ src[numChars] = '\0';
+
+ if ((cmdWords == 0)
+ && (!(iPtr->flags & DONT_COMPILE_CMDS_INLINE))) {
+ /*
+ * The first word of a command and inline command
+ * compilation has not been disabled (e.g., by command
+ * traces). Look up the first word in the interpreter's
+ * hashtable of commands. If a compilation procedure is
+ * found, let it compile the command after resetting
+ * error logging information.
+ */
+
+ cmdPtr = NULL;
+ cmd = Tcl_FindCommand(interp, src,
+ (Tcl_Namespace *) NULL, /*flags*/ 0);
+ if (cmd != (Tcl_Command) NULL) {
+ cmdPtr = (Command *) cmd;
+ }
+ if ((cmdPtr != NULL) && (cmdPtr->compileProc != NULL)) {
+ char *firstArg = termPtr;
+ src[numChars] = savedChar; /* restore chr */
+ iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS
+ | ERROR_CODE_SET);
+ result = (*(cmdPtr->compileProc))(interp,
+ firstArg, lastChar, flags, envPtr);
+ if (result == TCL_OK) {
+ src = (firstArg + envPtr->termOffset);
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ goto finishCommand; /* done with command */
+ } else if (result == TCL_OUT_LINE_COMPILE) {
+ result = TCL_OK; /* reset result */
+ src[numChars] = '\0';
+ } else {
+ src = firstArg;
+ goto done; /* an error */
+ }
+ }
+
+ /*
+ * No compile procedure was found for the command: push
+ * the word and continue to compile the remaining
+ * words. If a hashtable entry was found for the
+ * command, push a CmdName object instead to avoid
+ * runtime lookups. If necessary, convert the pushed
+ * object to be a CmdName object. If this is the first
+ * CmdName object in this code unit that refers to the
+ * command, increment the reference count in the
+ * Command structure to reflect the new reference from
+ * the CmdName object and, if the command is deleted
+ * later, to keep the Command structure from being freed
+ * until TclExecuteByteCode has a chance to recognize
+ * that the command was deleted.
+ */
+
+ objIndex = TclObjIndexForString(src, numChars,
+ /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ if (cmdPtr != NULL) {
+ objPtr = envPtr->objArrayPtr[objIndex];
+ if ((objPtr->typePtr != &tclCmdNameType)
+ && (objPtr->bytes != NULL)) {
+ ResolvedCmdName *resPtr = (ResolvedCmdName *)
+ ckalloc(sizeof(ResolvedCmdName));
+ Namespace *nsPtr = (Namespace *)
+ Tcl_GetCurrentNamespace(interp);
+
+ resPtr->cmdPtr = cmdPtr;
+ resPtr->refNsPtr = nsPtr;
+ resPtr->refNsId = nsPtr->nsId;
+ resPtr->refNsCmdEpoch = nsPtr->cmdRefEpoch;
+ resPtr->cmdEpoch = cmdPtr->cmdEpoch;
+ resPtr->refCount = 1;
+ objPtr->internalRep.otherValuePtr =
+ (VOID *) resPtr;
+ objPtr->typePtr = &tclCmdNameType;
+ cmdPtr->refCount++;
+ }
+ }
+ } else {
+ /*
+ * See if the word represents an integer whose formatted
+ * representation is the same as the word (e.g., this is
+ * true for 123 and -1 but not for 00005). If so, just
+ * push an integer object.
+ */
+
+ int isCompilableInt = 0;
+ long n;
+ char buf[40];
+
+ if (TclLooksLikeInt(src)) {
+ if (TclGetLong(interp, src, &n) == TCL_OK) {
+ TclFormatInt(buf, n);
+ if (strcmp(src, buf) == 0) {
+ isCompilableInt = 1;
+ objIndex = TclObjIndexForString(src,
+ numChars, /*allocStrRep*/ 0,
+ /*inHeap*/ 0, envPtr);
+ objPtr = envPtr->objArrayPtr[objIndex];
+
+ Tcl_InvalidateStringRep(objPtr);
+ objPtr->internalRep.longValue = n;
+ objPtr->typePtr = &tclIntType;
+ }
+ }
+ }
+ if (!isCompilableInt) {
+ objIndex = TclObjIndexForString(src, numChars,
+ /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ }
+ }
+ src[numChars] = savedChar; /* restore the saved char */
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = TclMax((cmdWords + 1), maxDepth);
+ } else { /* not a simple word */
+ maxDepth = TclMax((cmdWords + envPtr->maxStackDepth),
+ maxDepth);
+ }
+ src = termPtr;
+ c = *src;
+ type = CHAR_TYPE(src, lastChar);
+ cmdWords++;
+ }
+
+ /*
+ * Emit an invoke instruction for the command. If a compile command
+ * was found for the command we called it and skipped this.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ if ((cmdWords < 0) || (cmdWords > 10000)) {
+ fprintf(stderr, "\nTclCompileString: bad cmdWords value %d\n",
+ cmdWords);
+ panic("TclCompileString: bad cmdWords value %d");
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+ if (cmdWords > 0) {
+ if (cmdWords <= 255) {
+ TclEmitInstUInt1(INST_INVOKE_STK1, cmdWords, envPtr);
+ } else {
+ TclEmitInstUInt4(INST_INVOKE_STK4, cmdWords, envPtr);
+ }
+ }
+
+ /*
+ * Update the compilation environment structure. Record
+ * source/object information for the command if we are at the top
+ * level (i.e. we we called directly from SetByteCodeFromAny and are
+ * not compiling a substring enclosed in square brackets).
+ */
+
+ finishCommand:
+ if (!(flags & TCL_BRACKET_TERM)) {
+ int cmdSrcChars = (src - cmdSrcStart);
+ cmdCodeBytes =
+ (envPtr->codeNext - envPtr->codeStart - cmdCodeOffset);
+ EnterCmdExtentData(envPtr, cmdIndex, cmdSrcChars, cmdCodeBytes);
+ }
+ isFirstCmd = 0;
+ envPtr->termOffset = (src - string);
+ c = *src;
+ }
+
+ done:
+ if (result == TCL_OK) {
+ /*
+ * If the source string yielded no instructions (e.g., if it was
+ * empty), push an empty string object as the command's result.
+ */
+
+ if (entryCodeNext == envPtr->codeNext) {
+ int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0,
+ /*inHeap*/ 0, envPtr);
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = 1; /* we pushed 1 word for the empty string */
+ }
+ } else {
+ /*
+ * Add additional error information. First compute the line number
+ * where the error occurred.
+ */
+
+ int numChars;
+ register char *p;
+ char buf[200];
+
+ iPtr->errorLine = 1;
+ for (p = string; p != cmdSrcStart; p++) {
+ if (*p == '\n') {
+ iPtr->errorLine++;
+ }
+ }
+ for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) {
+ if (*p == '\n') {
+ iPtr->errorLine++;
+ }
+ }
+
+ /*
+ * Figure out how much of the command to print (up to a certain
+ * number of characters, or up to the first newline).
+ */
+
+ numChars = (src - cmdSrcStart);
+ if (numChars > 150) {
+ numChars = 150;
+ ellipsis = " ...";
+ }
+ sprintf(buf, "\n while compiling\n\"%.*s%s\"",
+ numChars, cmdSrcStart, ellipsis);
+ Tcl_AddObjErrorInfo(interp, buf, -1);
+ }
+
+ envPtr->termOffset = (src - string);
+ iPtr->termOffset = envPtr->termOffset;
+ envPtr->maxStackDepth = maxDepth;
+ envPtr->pushSimpleWords = savePushSimpleWords;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileWord --
+ *
+ * This procedure compiles one word from a command string. It skips
+ * any leading white space.
+ *
+ * Ordinarily, callers set envPtr->pushSimpleWords to 1 and this
+ * procedure emits push and other instructions to compute the
+ * word on the Tcl evaluation stack at execution time. If a caller sets
+ * envPtr->pushSimpleWords to 0, CompileWord will _not_ compile
+ * "simple" words: words that are just a sequence of characters without
+ * backslashes. It will leave their compilation up to the caller.
+ *
+ * As an important special case, if the word is simple, this procedure
+ * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
+ * number of characters in the simple word. This allows the caller to
+ * process these words specially.
+ *
+ * Results:
+ * The return value is a standard Tcl result. If an error occurs, an
+ * error message is left in the interpreter's result.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one successfully processed in the last
+ * word. This is normally the character just after the last one in a
+ * word (perhaps the command terminator), or the vicinity of an error
+ * (if the result is not TCL_OK).
+ *
+ * envPtr->wordIsSimple is set 1 if the word is simple: just a
+ * sequence of characters without backslashes. If so, the word's
+ * characters are the envPtr->numSimpleWordChars characters starting
+ * at string.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to evaluate the word. This is not changed if
+ * the word is simple and envPtr->pushSimpleWords was 0 (false).
+ *
+ * Side effects:
+ * Instructions are added to envPtr to compute and push the word
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileWord(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Interpreter to use for nested command
+ * evaluations and error messages. */
+ char *string; /* First character of word. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same values
+ * passed to Tcl_EvalObj). */
+ CompileEnv *envPtr; /* Holds the resulting instructions. */
+{
+ /*
+ * Compile one word: approximately
+ *
+ * word: quoted_string | braced_string | multipart_word
+ * quoted_string: '"' char* '"'
+ * braced_string: '{' char* '}'
+ * multipart_word (see CompileMultipartWord below)
+ */
+
+ register char *src = string; /* Points to current source char. */
+ register int type = CHAR_TYPE(src, lastChar);
+ /* Current char's CHAR_TYPE type. */
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to compute and push the word. */
+ char *termPtr = src; /* Poin