/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclbasic.c
ViewVC logotype

Diff of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclbasic.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 70 by dashley, Sun Oct 30 21:57:38 2016 UTC revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC
# Line 1  Line 1 
1  /* $Header$ */  /* $Header$ */
2  /*  /*
3   * tclBasic.c --   * tclBasic.c --
4   *   *
5   *      Contains the basic facilities for TCL command interpretation,   *      Contains the basic facilities for TCL command interpretation,
6   *      including interpreter creation and deletion, command creation   *      including interpreter creation and deletion, command creation
7   *      and deletion, and command parsing and execution.   *      and deletion, and command parsing and execution.
8   *   *
9   * Copyright (c) 1987-1994 The Regents of the University of California.   * Copyright (c) 1987-1994 The Regents of the University of California.
10   * Copyright (c) 1994-1997 Sun Microsystems, Inc.   * Copyright (c) 1994-1997 Sun Microsystems, Inc.
11   * Copyright (c) 1998-1999 by Scriptics Corporation.   * Copyright (c) 1998-1999 by Scriptics Corporation.
12   *   *
13   * See the file "license.terms" for information on usage and redistribution   * See the file "license.terms" for information on usage and redistribution
14   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15   *   *
16   * RCS: @(#) $Id: tclbasic.c,v 1.1.1.1 2001/06/13 04:33:43 dtashley Exp $   * RCS: @(#) $Id: tclbasic.c,v 1.1.1.1 2001/06/13 04:33:43 dtashley Exp $
17   */   */
18    
19  #include "tclInt.h"  #include "tclInt.h"
20  #include "tclCompile.h"  #include "tclCompile.h"
21  #ifndef TCL_GENERIC_ONLY  #ifndef TCL_GENERIC_ONLY
22  #   include "tclPort.h"  #   include "tclPort.h"
23  #endif  #endif
24    
25  /*  /*
26   * Static procedures in this file:   * Static procedures in this file:
27   */   */
28    
29  static void             DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));  static void             DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
30  static void             ProcessUnexpectedResult _ANSI_ARGS_((  static void             ProcessUnexpectedResult _ANSI_ARGS_((
31                              Tcl_Interp *interp, int returnCode));                              Tcl_Interp *interp, int returnCode));
32  static void             RecordTracebackInfo _ANSI_ARGS_((  static void             RecordTracebackInfo _ANSI_ARGS_((
33                              Tcl_Interp *interp, Tcl_Obj *objPtr,                              Tcl_Interp *interp, Tcl_Obj *objPtr,
34                              int numSrcBytes));                              int numSrcBytes));
35    
36  extern TclStubs tclStubs;  extern TclStubs tclStubs;
37    
38  /*  /*
39   * The following structure defines the commands in the Tcl core.   * The following structure defines the commands in the Tcl core.
40   */   */
41    
42  typedef struct {  typedef struct {
43      char *name;                 /* Name of object-based command. */      char *name;                 /* Name of object-based command. */
44      Tcl_CmdProc *proc;          /* String-based procedure for command. */      Tcl_CmdProc *proc;          /* String-based procedure for command. */
45      Tcl_ObjCmdProc *objProc;    /* Object-based procedure for command. */      Tcl_ObjCmdProc *objProc;    /* Object-based procedure for command. */
46      CompileProc *compileProc;   /* Procedure called to compile command. */      CompileProc *compileProc;   /* Procedure called to compile command. */
47      int isSafe;                 /* If non-zero, command will be present      int isSafe;                 /* If non-zero, command will be present
48                                   * in safe interpreter. Otherwise it will                                   * in safe interpreter. Otherwise it will
49                                   * be hidden. */                                   * be hidden. */
50  } CmdInfo;  } CmdInfo;
51    
52  /*  /*
53   * The built-in commands, and the procedures that implement them:   * The built-in commands, and the procedures that implement them:
54   */   */
55    
56  static CmdInfo builtInCmds[] = {  static CmdInfo builtInCmds[] = {
57      /*      /*
58       * Commands in the generic core. Note that at least one of the proc or       * Commands in the generic core. Note that at least one of the proc or
59       * objProc members should be non-NULL. This avoids infinitely recursive       * objProc members should be non-NULL. This avoids infinitely recursive
60       * calls between TclInvokeObjectCommand and TclInvokeStringCommand if a       * calls between TclInvokeObjectCommand and TclInvokeStringCommand if a
61       * command name is computed at runtime and results in the name of a       * command name is computed at runtime and results in the name of a
62       * compiled command.       * compiled command.
63       */       */
64    
65      {"append",          (Tcl_CmdProc *) NULL,   Tcl_AppendObjCmd,      {"append",          (Tcl_CmdProc *) NULL,   Tcl_AppendObjCmd,
66          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
67      {"array",           (Tcl_CmdProc *) NULL,   Tcl_ArrayObjCmd,      {"array",           (Tcl_CmdProc *) NULL,   Tcl_ArrayObjCmd,
68          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
69      {"binary",          (Tcl_CmdProc *) NULL,   Tcl_BinaryObjCmd,      {"binary",          (Tcl_CmdProc *) NULL,   Tcl_BinaryObjCmd,
70          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
71      {"break",           (Tcl_CmdProc *) NULL,   Tcl_BreakObjCmd,      {"break",           (Tcl_CmdProc *) NULL,   Tcl_BreakObjCmd,
72          TclCompileBreakCmd,             1},          TclCompileBreakCmd,             1},
73      {"case",            (Tcl_CmdProc *) NULL,   Tcl_CaseObjCmd,      {"case",            (Tcl_CmdProc *) NULL,   Tcl_CaseObjCmd,
74          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
75      {"catch",           (Tcl_CmdProc *) NULL,   Tcl_CatchObjCmd,              {"catch",           (Tcl_CmdProc *) NULL,   Tcl_CatchObjCmd,        
76          TclCompileCatchCmd,             1},          TclCompileCatchCmd,             1},
77      {"clock",           (Tcl_CmdProc *) NULL,   Tcl_ClockObjCmd,      {"clock",           (Tcl_CmdProc *) NULL,   Tcl_ClockObjCmd,
78          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
79      {"concat",          (Tcl_CmdProc *) NULL,   Tcl_ConcatObjCmd,      {"concat",          (Tcl_CmdProc *) NULL,   Tcl_ConcatObjCmd,
80          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
81      {"continue",        (Tcl_CmdProc *) NULL,   Tcl_ContinueObjCmd,      {"continue",        (Tcl_CmdProc *) NULL,   Tcl_ContinueObjCmd,
82          TclCompileContinueCmd,          1},          TclCompileContinueCmd,          1},
83      {"encoding",        (Tcl_CmdProc *) NULL,   Tcl_EncodingObjCmd,      {"encoding",        (Tcl_CmdProc *) NULL,   Tcl_EncodingObjCmd,
84          (CompileProc *) NULL,           0},          (CompileProc *) NULL,           0},
85      {"error",           (Tcl_CmdProc *) NULL,   Tcl_ErrorObjCmd,      {"error",           (Tcl_CmdProc *) NULL,   Tcl_ErrorObjCmd,
86          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
87      {"eval",            (Tcl_CmdProc *) NULL,   Tcl_EvalObjCmd,      {"eval",            (Tcl_CmdProc *) NULL,   Tcl_EvalObjCmd,
88          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
89      {"exit",            (Tcl_CmdProc *) NULL,   Tcl_ExitObjCmd,      {"exit",            (Tcl_CmdProc *) NULL,   Tcl_ExitObjCmd,
90          (CompileProc *) NULL,           0},          (CompileProc *) NULL,           0},
91      {"expr",            (Tcl_CmdProc *) NULL,   Tcl_ExprObjCmd,      {"expr",            (Tcl_CmdProc *) NULL,   Tcl_ExprObjCmd,
92          TclCompileExprCmd,              1},          TclCompileExprCmd,              1},
93      {"fcopy",           (Tcl_CmdProc *) NULL,   Tcl_FcopyObjCmd,      {"fcopy",           (Tcl_CmdProc *) NULL,   Tcl_FcopyObjCmd,
94          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
95      {"fileevent",       (Tcl_CmdProc *) NULL,   Tcl_FileEventObjCmd,      {"fileevent",       (Tcl_CmdProc *) NULL,   Tcl_FileEventObjCmd,
96          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
97      {"for",             (Tcl_CmdProc *) NULL,   Tcl_ForObjCmd,      {"for",             (Tcl_CmdProc *) NULL,   Tcl_ForObjCmd,
98          TclCompileForCmd,               1},          TclCompileForCmd,               1},
99      {"foreach",         (Tcl_CmdProc *) NULL,   Tcl_ForeachObjCmd,      {"foreach",         (Tcl_CmdProc *) NULL,   Tcl_ForeachObjCmd,
100          TclCompileForeachCmd,           1},          TclCompileForeachCmd,           1},
101      {"format",          (Tcl_CmdProc *) NULL,   Tcl_FormatObjCmd,      {"format",          (Tcl_CmdProc *) NULL,   Tcl_FormatObjCmd,
102          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
103      {"global",          (Tcl_CmdProc *) NULL,   Tcl_GlobalObjCmd,      {"global",          (Tcl_CmdProc *) NULL,   Tcl_GlobalObjCmd,
104          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
105      {"if",              (Tcl_CmdProc *) NULL,   Tcl_IfObjCmd,      {"if",              (Tcl_CmdProc *) NULL,   Tcl_IfObjCmd,
106          TclCompileIfCmd,                1},          TclCompileIfCmd,                1},
107      {"incr",            (Tcl_CmdProc *) NULL,   Tcl_IncrObjCmd,      {"incr",            (Tcl_CmdProc *) NULL,   Tcl_IncrObjCmd,
108          TclCompileIncrCmd,              1},          TclCompileIncrCmd,              1},
109      {"info",            (Tcl_CmdProc *) NULL,   Tcl_InfoObjCmd,      {"info",            (Tcl_CmdProc *) NULL,   Tcl_InfoObjCmd,
110          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
111      {"join",            (Tcl_CmdProc *) NULL,   Tcl_JoinObjCmd,      {"join",            (Tcl_CmdProc *) NULL,   Tcl_JoinObjCmd,
112          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
113      {"lappend",         (Tcl_CmdProc *) NULL,   Tcl_LappendObjCmd,      {"lappend",         (Tcl_CmdProc *) NULL,   Tcl_LappendObjCmd,
114          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
115      {"lindex",          (Tcl_CmdProc *) NULL,   Tcl_LindexObjCmd,      {"lindex",          (Tcl_CmdProc *) NULL,   Tcl_LindexObjCmd,
116          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
117      {"linsert",         (Tcl_CmdProc *) NULL,   Tcl_LinsertObjCmd,      {"linsert",         (Tcl_CmdProc *) NULL,   Tcl_LinsertObjCmd,
118          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
119      {"list",            (Tcl_CmdProc *) NULL,   Tcl_ListObjCmd,      {"list",            (Tcl_CmdProc *) NULL,   Tcl_ListObjCmd,
120          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
121      {"llength",         (Tcl_CmdProc *) NULL,   Tcl_LlengthObjCmd,      {"llength",         (Tcl_CmdProc *) NULL,   Tcl_LlengthObjCmd,
122          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
123      {"load",            (Tcl_CmdProc *) NULL,   Tcl_LoadObjCmd,      {"load",            (Tcl_CmdProc *) NULL,   Tcl_LoadObjCmd,
124          (CompileProc *) NULL,           0},          (CompileProc *) NULL,           0},
125      {"lrange",          (Tcl_CmdProc *) NULL,   Tcl_LrangeObjCmd,      {"lrange",          (Tcl_CmdProc *) NULL,   Tcl_LrangeObjCmd,
126          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
127      {"lreplace",        (Tcl_CmdProc *) NULL,   Tcl_LreplaceObjCmd,      {"lreplace",        (Tcl_CmdProc *) NULL,   Tcl_LreplaceObjCmd,
128          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
129      {"lsearch",         (Tcl_CmdProc *) NULL,   Tcl_LsearchObjCmd,      {"lsearch",         (Tcl_CmdProc *) NULL,   Tcl_LsearchObjCmd,
130          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
131      {"lsort",           (Tcl_CmdProc *) NULL,   Tcl_LsortObjCmd,      {"lsort",           (Tcl_CmdProc *) NULL,   Tcl_LsortObjCmd,
132          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
133      {"namespace",       (Tcl_CmdProc *) NULL,   Tcl_NamespaceObjCmd,      {"namespace",       (Tcl_CmdProc *) NULL,   Tcl_NamespaceObjCmd,
134          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
135      {"package",         (Tcl_CmdProc *) NULL,   Tcl_PackageObjCmd,      {"package",         (Tcl_CmdProc *) NULL,   Tcl_PackageObjCmd,
136          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
137      {"proc",            (Tcl_CmdProc *) NULL,   Tcl_ProcObjCmd,      {"proc",            (Tcl_CmdProc *) NULL,   Tcl_ProcObjCmd,
138          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
139      {"regexp",          (Tcl_CmdProc *) NULL,   Tcl_RegexpObjCmd,      {"regexp",          (Tcl_CmdProc *) NULL,   Tcl_RegexpObjCmd,
140          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
141      {"regsub",          (Tcl_CmdProc *) NULL,   Tcl_RegsubObjCmd,      {"regsub",          (Tcl_CmdProc *) NULL,   Tcl_RegsubObjCmd,
142          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
143      {"rename",          (Tcl_CmdProc *) NULL,   Tcl_RenameObjCmd,      {"rename",          (Tcl_CmdProc *) NULL,   Tcl_RenameObjCmd,
144          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
145      {"return",          (Tcl_CmdProc *) NULL,   Tcl_ReturnObjCmd,            {"return",          (Tcl_CmdProc *) NULL,   Tcl_ReturnObjCmd,      
146          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
147      {"scan",            (Tcl_CmdProc *) NULL,   Tcl_ScanObjCmd,      {"scan",            (Tcl_CmdProc *) NULL,   Tcl_ScanObjCmd,
148          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
149      {"set",             (Tcl_CmdProc *) NULL,   Tcl_SetObjCmd,      {"set",             (Tcl_CmdProc *) NULL,   Tcl_SetObjCmd,
150          TclCompileSetCmd,               1},          TclCompileSetCmd,               1},
151      {"split",           (Tcl_CmdProc *) NULL,   Tcl_SplitObjCmd,      {"split",           (Tcl_CmdProc *) NULL,   Tcl_SplitObjCmd,
152          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
153      {"string",          (Tcl_CmdProc *) NULL,   Tcl_StringObjCmd,      {"string",          (Tcl_CmdProc *) NULL,   Tcl_StringObjCmd,
154          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
155      {"subst",           (Tcl_CmdProc *) NULL,   Tcl_SubstObjCmd,      {"subst",           (Tcl_CmdProc *) NULL,   Tcl_SubstObjCmd,
156          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
157      {"switch",          (Tcl_CmdProc *) NULL,   Tcl_SwitchObjCmd,            {"switch",          (Tcl_CmdProc *) NULL,   Tcl_SwitchObjCmd,      
158          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
159      {"trace",           (Tcl_CmdProc *) NULL,   Tcl_TraceObjCmd,      {"trace",           (Tcl_CmdProc *) NULL,   Tcl_TraceObjCmd,
160          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
161      {"unset",           (Tcl_CmdProc *) NULL,   Tcl_UnsetObjCmd,              {"unset",           (Tcl_CmdProc *) NULL,   Tcl_UnsetObjCmd,        
162          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
163      {"uplevel",         (Tcl_CmdProc *) NULL,   Tcl_UplevelObjCmd,            {"uplevel",         (Tcl_CmdProc *) NULL,   Tcl_UplevelObjCmd,      
164          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
165      {"upvar",           (Tcl_CmdProc *) NULL,   Tcl_UpvarObjCmd,              {"upvar",           (Tcl_CmdProc *) NULL,   Tcl_UpvarObjCmd,        
166          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
167      {"variable",        (Tcl_CmdProc *) NULL,   Tcl_VariableObjCmd,      {"variable",        (Tcl_CmdProc *) NULL,   Tcl_VariableObjCmd,
168          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
169      {"while",           (Tcl_CmdProc *) NULL,   Tcl_WhileObjCmd,      {"while",           (Tcl_CmdProc *) NULL,   Tcl_WhileObjCmd,
170          TclCompileWhileCmd,             1},          TclCompileWhileCmd,             1},
171    
172      /*      /*
173       * Commands in the UNIX core:       * Commands in the UNIX core:
174       */       */
175    
176  #ifndef TCL_GENERIC_ONLY  #ifndef TCL_GENERIC_ONLY
177      {"after",           (Tcl_CmdProc *) NULL,   Tcl_AfterObjCmd,      {"after",           (Tcl_CmdProc *) NULL,   Tcl_AfterObjCmd,
178          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
179      {"cd",              (Tcl_CmdProc *) NULL,   Tcl_CdObjCmd,      {"cd",              (Tcl_CmdProc *) NULL,   Tcl_CdObjCmd,
180          (CompileProc *) NULL,           0},          (CompileProc *) NULL,           0},
181      {"close",           (Tcl_CmdProc *) NULL,   Tcl_CloseObjCmd,      {"close",           (Tcl_CmdProc *) NULL,   Tcl_CloseObjCmd,
182          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
183      {"eof",             (Tcl_CmdProc *) NULL,   Tcl_EofObjCmd,      {"eof",             (Tcl_CmdProc *) NULL,   Tcl_EofObjCmd,
184          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
185      {"fblocked",        (Tcl_CmdProc *) NULL,   Tcl_FblockedObjCmd,      {"fblocked",        (Tcl_CmdProc *) NULL,   Tcl_FblockedObjCmd,
186          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
187      {"fconfigure",      (Tcl_CmdProc *) NULL,   Tcl_FconfigureObjCmd,      {"fconfigure",      (Tcl_CmdProc *) NULL,   Tcl_FconfigureObjCmd,
188          (CompileProc *) NULL,           0},          (CompileProc *) NULL,           0},
189      {"file",            (Tcl_CmdProc *) NULL,   Tcl_FileObjCmd,      {"file",            (Tcl_CmdProc *) NULL,   Tcl_FileObjCmd,
190          (CompileProc *) NULL,           0},          (CompileProc *) NULL,           0},
191      {"flush",           (Tcl_CmdProc *) NULL,   Tcl_FlushObjCmd,      {"flush",           (Tcl_CmdProc *) NULL,   Tcl_FlushObjCmd,
192          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
193      {"gets",            (Tcl_CmdProc *) NULL,   Tcl_GetsObjCmd,      {"gets",            (Tcl_CmdProc *) NULL,   Tcl_GetsObjCmd,
194          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
195      {"glob",            (Tcl_CmdProc *) NULL,   Tcl_GlobObjCmd,      {"glob",            (Tcl_CmdProc *) NULL,   Tcl_GlobObjCmd,
196          (CompileProc *) NULL,           0},          (CompileProc *) NULL,           0},
197      {"open",            (Tcl_CmdProc *) NULL,   Tcl_OpenObjCmd,      {"open",            (Tcl_CmdProc *) NULL,   Tcl_OpenObjCmd,
198          (CompileProc *) NULL,           0},          (CompileProc *) NULL,           0},
199      {"pid",             (Tcl_CmdProc *) NULL,   Tcl_PidObjCmd,      {"pid",             (Tcl_CmdProc *) NULL,   Tcl_PidObjCmd,
200          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
201      {"puts",            (Tcl_CmdProc *) NULL,   Tcl_PutsObjCmd,      {"puts",            (Tcl_CmdProc *) NULL,   Tcl_PutsObjCmd,
202          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
203      {"pwd",             (Tcl_CmdProc *) NULL,   Tcl_PwdObjCmd,      {"pwd",             (Tcl_CmdProc *) NULL,   Tcl_PwdObjCmd,
204          (CompileProc *) NULL,           0},          (CompileProc *) NULL,           0},
205      {"read",            (Tcl_CmdProc *) NULL,   Tcl_ReadObjCmd,      {"read",            (Tcl_CmdProc *) NULL,   Tcl_ReadObjCmd,
206          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
207      {"seek",            (Tcl_CmdProc *) NULL,   Tcl_SeekObjCmd,      {"seek",            (Tcl_CmdProc *) NULL,   Tcl_SeekObjCmd,
208          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
209      {"socket",          (Tcl_CmdProc *) NULL,   Tcl_SocketObjCmd,      {"socket",          (Tcl_CmdProc *) NULL,   Tcl_SocketObjCmd,
210          (CompileProc *) NULL,           0},          (CompileProc *) NULL,           0},
211      {"tell",            (Tcl_CmdProc *) NULL,   Tcl_TellObjCmd,      {"tell",            (Tcl_CmdProc *) NULL,   Tcl_TellObjCmd,
212          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
213      {"time",            (Tcl_CmdProc *) NULL,   Tcl_TimeObjCmd,      {"time",            (Tcl_CmdProc *) NULL,   Tcl_TimeObjCmd,
214          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
215      {"update",          (Tcl_CmdProc *) NULL,   Tcl_UpdateObjCmd,      {"update",          (Tcl_CmdProc *) NULL,   Tcl_UpdateObjCmd,
216          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
217      {"vwait",           (Tcl_CmdProc *) NULL,   Tcl_VwaitObjCmd,      {"vwait",           (Tcl_CmdProc *) NULL,   Tcl_VwaitObjCmd,
218          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
219            
220  #ifdef MAC_TCL  #ifdef MAC_TCL
221      {"beep",            (Tcl_CmdProc *) NULL,   Tcl_BeepObjCmd,      {"beep",            (Tcl_CmdProc *) NULL,   Tcl_BeepObjCmd,
222          (CompileProc *) NULL,           0},          (CompileProc *) NULL,           0},
223      {"echo",            Tcl_EchoCmd,            (Tcl_ObjCmdProc *) NULL,      {"echo",            Tcl_EchoCmd,            (Tcl_ObjCmdProc *) NULL,
224          (CompileProc *) NULL,           0},          (CompileProc *) NULL,           0},
225      {"ls",              (Tcl_CmdProc *) NULL,   Tcl_LsObjCmd,      {"ls",              (Tcl_CmdProc *) NULL,   Tcl_LsObjCmd,
226          (CompileProc *) NULL,           0},          (CompileProc *) NULL,           0},
227      {"resource",        (Tcl_CmdProc *) NULL,   Tcl_ResourceObjCmd,      {"resource",        (Tcl_CmdProc *) NULL,   Tcl_ResourceObjCmd,
228          (CompileProc *) NULL,           1},          (CompileProc *) NULL,           1},
229      {"source",          (Tcl_CmdProc *) NULL,   Tcl_MacSourceObjCmd,      {"source",          (Tcl_CmdProc *) NULL,   Tcl_MacSourceObjCmd,
230          (CompileProc *) NULL,           0},          (CompileProc *) NULL,           0},
231  #else  #else
232      {"exec",            (Tcl_CmdProc *) NULL,   Tcl_ExecObjCmd,      {"exec",            (Tcl_CmdProc *) NULL,   Tcl_ExecObjCmd,
233          (CompileProc *) NULL,           0},          (CompileProc *) NULL,           0},
234      {"source",          (Tcl_CmdProc *) NULL,   Tcl_SourceObjCmd,      {"source",          (Tcl_CmdProc *) NULL,   Tcl_SourceObjCmd,
235          (CompileProc *) NULL,           0},          (CompileProc *) NULL,           0},
236  #endif /* MAC_TCL */  #endif /* MAC_TCL */
237            
238  #endif /* TCL_GENERIC_ONLY */  #endif /* TCL_GENERIC_ONLY */
239      {NULL,              (Tcl_CmdProc *) NULL,   (Tcl_ObjCmdProc *) NULL,      {NULL,              (Tcl_CmdProc *) NULL,   (Tcl_ObjCmdProc *) NULL,
240          (CompileProc *) NULL,           0}          (CompileProc *) NULL,           0}
241  };  };
242    
243    
244  /*  /*
245   *----------------------------------------------------------------------   *----------------------------------------------------------------------
246   *   *
247   * Tcl_CreateInterp --   * Tcl_CreateInterp --
248   *   *
249   *      Create a new TCL command interpreter.   *      Create a new TCL command interpreter.
250   *   *
251   * Results:   * Results:
252   *      The return value is a token for the interpreter, which may be   *      The return value is a token for the interpreter, which may be
253   *      used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or   *      used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
254   *      Tcl_DeleteInterp.   *      Tcl_DeleteInterp.
255   *   *
256   * Side effects:   * Side effects:
257   *      The command interpreter is initialized with an empty variable   *      The command interpreter is initialized with an empty variable
258   *      table and the built-in commands.   *      table and the built-in commands.
259   *   *
260   *----------------------------------------------------------------------   *----------------------------------------------------------------------
261   */   */
262    
263  Tcl_Interp *  Tcl_Interp *
264  Tcl_CreateInterp()  Tcl_CreateInterp()
265  {  {
266      Interp *iPtr;      Interp *iPtr;
267      Tcl_Interp *interp;      Tcl_Interp *interp;
268      Command *cmdPtr;      Command *cmdPtr;
269      BuiltinFunc *builtinFuncPtr;      BuiltinFunc *builtinFuncPtr;
270      MathFunc *mathFuncPtr;      MathFunc *mathFuncPtr;
271      Tcl_HashEntry *hPtr;      Tcl_HashEntry *hPtr;
272      CmdInfo *cmdInfoPtr;      CmdInfo *cmdInfoPtr;
273      int i;      int i;
274      union {      union {
275          char c[sizeof(short)];          char c[sizeof(short)];
276          short s;          short s;
277      } order;      } order;
278  #ifdef TCL_COMPILE_STATS  #ifdef TCL_COMPILE_STATS
279      ByteCodeStats *statsPtr;      ByteCodeStats *statsPtr;
280  #endif /* TCL_COMPILE_STATS */  #endif /* TCL_COMPILE_STATS */
281    
282      TclInitSubsystems(NULL);      TclInitSubsystems(NULL);
283    
284      /*      /*
285       * Panic if someone updated the CallFrame structure without       * Panic if someone updated the CallFrame structure without
286       * also updating the Tcl_CallFrame structure (or vice versa).       * also updating the Tcl_CallFrame structure (or vice versa).
287       */         */  
288    
289      if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) {      if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) {
290          /*NOTREACHED*/          /*NOTREACHED*/
291          panic("Tcl_CallFrame and CallFrame are not the same size");          panic("Tcl_CallFrame and CallFrame are not the same size");
292      }      }
293    
294      /*      /*
295       * Initialize support for namespaces and create the global namespace       * Initialize support for namespaces and create the global namespace
296       * (whose name is ""; an alias is "::"). This also initializes the       * (whose name is ""; an alias is "::"). This also initializes the
297       * Tcl object type table and other object management code.       * Tcl object type table and other object management code.
298       */       */
299    
300      iPtr = (Interp *) ckalloc(sizeof(Interp));      iPtr = (Interp *) ckalloc(sizeof(Interp));
301      interp = (Tcl_Interp *) iPtr;      interp = (Tcl_Interp *) iPtr;
302    
303      iPtr->result                = iPtr->resultSpace;      iPtr->result                = iPtr->resultSpace;
304      iPtr->freeProc              = NULL;      iPtr->freeProc              = NULL;
305      iPtr->errorLine             = 0;      iPtr->errorLine             = 0;
306      iPtr->objResultPtr          = Tcl_NewObj();      iPtr->objResultPtr          = Tcl_NewObj();
307      Tcl_IncrRefCount(iPtr->objResultPtr);      Tcl_IncrRefCount(iPtr->objResultPtr);
308      iPtr->handle                = TclHandleCreate(iPtr);      iPtr->handle                = TclHandleCreate(iPtr);
309      iPtr->globalNsPtr           = NULL;      iPtr->globalNsPtr           = NULL;
310      iPtr->hiddenCmdTablePtr     = NULL;      iPtr->hiddenCmdTablePtr     = NULL;
311      iPtr->interpInfo            = NULL;      iPtr->interpInfo            = NULL;
312      Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);      Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
313    
314      iPtr->numLevels = 0;      iPtr->numLevels = 0;
315      iPtr->maxNestingDepth = 1000;      iPtr->maxNestingDepth = 1000;
316      iPtr->framePtr = NULL;      iPtr->framePtr = NULL;
317      iPtr->varFramePtr = NULL;      iPtr->varFramePtr = NULL;
318      iPtr->activeTracePtr = NULL;      iPtr->activeTracePtr = NULL;
319      iPtr->returnCode = TCL_OK;      iPtr->returnCode = TCL_OK;
320      iPtr->errorInfo = NULL;      iPtr->errorInfo = NULL;
321      iPtr->errorCode = NULL;      iPtr->errorCode = NULL;
322    
323      iPtr->appendResult = NULL;      iPtr->appendResult = NULL;
324      iPtr->appendAvl = 0;      iPtr->appendAvl = 0;
325      iPtr->appendUsed = 0;      iPtr->appendUsed = 0;
326    
327      Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);      Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
328      iPtr->packageUnknown = NULL;      iPtr->packageUnknown = NULL;
329      iPtr->cmdCount = 0;      iPtr->cmdCount = 0;
330      iPtr->termOffset = 0;      iPtr->termOffset = 0;
331      TclInitLiteralTable(&(iPtr->literalTable));      TclInitLiteralTable(&(iPtr->literalTable));
332      iPtr->compileEpoch = 0;      iPtr->compileEpoch = 0;
333      iPtr->compiledProcPtr = NULL;      iPtr->compiledProcPtr = NULL;
334      iPtr->resolverPtr = NULL;      iPtr->resolverPtr = NULL;
335      iPtr->evalFlags = 0;      iPtr->evalFlags = 0;
336      iPtr->scriptFile = NULL;      iPtr->scriptFile = NULL;
337      iPtr->flags = 0;      iPtr->flags = 0;
338      iPtr->tracePtr = NULL;      iPtr->tracePtr = NULL;
339      iPtr->assocData = (Tcl_HashTable *) NULL;      iPtr->assocData = (Tcl_HashTable *) NULL;
340      iPtr->execEnvPtr = NULL;          /* set after namespaces initialized */      iPtr->execEnvPtr = NULL;          /* set after namespaces initialized */
341      iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */      iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */
342      Tcl_IncrRefCount(iPtr->emptyObjPtr);      Tcl_IncrRefCount(iPtr->emptyObjPtr);
343      iPtr->resultSpace[0] = 0;      iPtr->resultSpace[0] = 0;
344    
345      iPtr->globalNsPtr = NULL;   /* force creation of global ns below */      iPtr->globalNsPtr = NULL;   /* force creation of global ns below */
346      iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "",      iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "",
347              (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);              (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
348      if (iPtr->globalNsPtr == NULL) {      if (iPtr->globalNsPtr == NULL) {
349          panic("Tcl_CreateInterp: can't create global namespace");          panic("Tcl_CreateInterp: can't create global namespace");
350      }      }
351    
352      /*      /*
353       * Initialize support for code compilation and execution. We call       * Initialize support for code compilation and execution. We call
354       * TclCreateExecEnv after initializing namespaces since it tries to       * TclCreateExecEnv after initializing namespaces since it tries to
355       * reference a Tcl variable (it links to the Tcl "tcl_traceExec"       * reference a Tcl variable (it links to the Tcl "tcl_traceExec"
356       * variable).       * variable).
357       */       */
358    
359      iPtr->execEnvPtr = TclCreateExecEnv(interp);      iPtr->execEnvPtr = TclCreateExecEnv(interp);
360    
361      /*      /*
362       * Initialize the compilation and execution statistics kept for this       * Initialize the compilation and execution statistics kept for this
363       * interpreter.       * interpreter.
364       */       */
365    
366  #ifdef TCL_COMPILE_STATS  #ifdef TCL_COMPILE_STATS
367      statsPtr = &(iPtr->stats);      statsPtr = &(iPtr->stats);
368      statsPtr->numExecutions = 0;      statsPtr->numExecutions = 0;
369      statsPtr->numCompilations = 0;      statsPtr->numCompilations = 0;
370      statsPtr->numByteCodesFreed = 0;      statsPtr->numByteCodesFreed = 0;
371      (VOID *) memset(statsPtr->instructionCount, 0,      (VOID *) memset(statsPtr->instructionCount, 0,
372              sizeof(statsPtr->instructionCount));              sizeof(statsPtr->instructionCount));
373    
374      statsPtr->totalSrcBytes = 0.0;      statsPtr->totalSrcBytes = 0.0;
375      statsPtr->totalByteCodeBytes = 0.0;      statsPtr->totalByteCodeBytes = 0.0;
376      statsPtr->currentSrcBytes = 0.0;      statsPtr->currentSrcBytes = 0.0;
377      statsPtr->currentByteCodeBytes = 0.0;      statsPtr->currentByteCodeBytes = 0.0;
378      (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount));      (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount));
379      (VOID *) memset(statsPtr->byteCodeCount, 0,      (VOID *) memset(statsPtr->byteCodeCount, 0,
380              sizeof(statsPtr->byteCodeCount));              sizeof(statsPtr->byteCodeCount));
381      (VOID *) memset(statsPtr->lifetimeCount, 0,      (VOID *) memset(statsPtr->lifetimeCount, 0,
382              sizeof(statsPtr->lifetimeCount));              sizeof(statsPtr->lifetimeCount));
383            
384      statsPtr->currentInstBytes   = 0.0;      statsPtr->currentInstBytes   = 0.0;
385      statsPtr->currentLitBytes    = 0.0;      statsPtr->currentLitBytes    = 0.0;
386      statsPtr->currentExceptBytes = 0.0;      statsPtr->currentExceptBytes = 0.0;
387      statsPtr->currentAuxBytes    = 0.0;      statsPtr->currentAuxBytes    = 0.0;
388      statsPtr->currentCmdMapBytes = 0.0;      statsPtr->currentCmdMapBytes = 0.0;
389            
390      statsPtr->numLiteralsCreated    = 0;      statsPtr->numLiteralsCreated    = 0;
391      statsPtr->totalLitStringBytes   = 0.0;      statsPtr->totalLitStringBytes   = 0.0;
392      statsPtr->currentLitStringBytes = 0.0;      statsPtr->currentLitStringBytes = 0.0;
393      (VOID *) memset(statsPtr->literalCount, 0,      (VOID *) memset(statsPtr->literalCount, 0,
394              sizeof(statsPtr->literalCount));              sizeof(statsPtr->literalCount));
395  #endif /* TCL_COMPILE_STATS */      #endif /* TCL_COMPILE_STATS */    
396    
397      /*      /*
398       * Initialise the stub table pointer.       * Initialise the stub table pointer.
399       */       */
400    
401      iPtr->stubTable = &tclStubs;      iPtr->stubTable = &tclStubs;
402    
403            
404      /*      /*
405       * Create the core commands. Do it here, rather than calling       * Create the core commands. Do it here, rather than calling
406       * Tcl_CreateCommand, because it's faster (there's no need to check for       * Tcl_CreateCommand, because it's faster (there's no need to check for
407       * a pre-existing command by the same name). If a command has a       * a pre-existing command by the same name). If a command has a
408       * Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to       * Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to
409       * TclInvokeStringCommand. This is an object-based wrapper procedure       * TclInvokeStringCommand. This is an object-based wrapper procedure
410       * that extracts strings, calls the string procedure, and creates an       * that extracts strings, calls the string procedure, and creates an
411       * object for the result. Similarly, if a command has a Tcl_ObjCmdProc       * object for the result. Similarly, if a command has a Tcl_ObjCmdProc
412       * but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand.       * but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand.
413       */       */
414    
415      for (cmdInfoPtr = builtInCmds;  cmdInfoPtr->name != NULL;      for (cmdInfoPtr = builtInCmds;  cmdInfoPtr->name != NULL;
416              cmdInfoPtr++) {              cmdInfoPtr++) {
417          int new;          int new;
418          Tcl_HashEntry *hPtr;          Tcl_HashEntry *hPtr;
419    
420          if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL)          if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL)
421                  && (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL)                  && (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL)
422                  && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) {                  && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) {
423              panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n");              panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n");
424          }          }
425                    
426          hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,          hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
427                  cmdInfoPtr->name, &new);                  cmdInfoPtr->name, &new);
428          if (new) {          if (new) {
429              cmdPtr = (Command *) ckalloc(sizeof(Command));              cmdPtr = (Command *) ckalloc(sizeof(Command));
430              cmdPtr->hPtr = hPtr;              cmdPtr->hPtr = hPtr;
431              cmdPtr->nsPtr = iPtr->globalNsPtr;              cmdPtr->nsPtr = iPtr->globalNsPtr;
432              cmdPtr->refCount = 1;              cmdPtr->refCount = 1;
433              cmdPtr->cmdEpoch = 0;              cmdPtr->cmdEpoch = 0;
434              cmdPtr->compileProc = cmdInfoPtr->compileProc;              cmdPtr->compileProc = cmdInfoPtr->compileProc;
435              if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) {              if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) {
436                  cmdPtr->proc = TclInvokeObjectCommand;                  cmdPtr->proc = TclInvokeObjectCommand;
437                  cmdPtr->clientData = (ClientData) cmdPtr;                  cmdPtr->clientData = (ClientData) cmdPtr;
438              } else {              } else {
439                  cmdPtr->proc = cmdInfoPtr->proc;                  cmdPtr->proc = cmdInfoPtr->proc;
440                  cmdPtr->clientData = (ClientData) NULL;                  cmdPtr->clientData = (ClientData) NULL;
441              }              }
442              if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {              if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
443                  cmdPtr->objProc = TclInvokeStringCommand;                  cmdPtr->objProc = TclInvokeStringCommand;
444                  cmdPtr->objClientData = (ClientData) cmdPtr;                  cmdPtr->objClientData = (ClientData) cmdPtr;
445              } else {              } else {
446                  cmdPtr->objProc = cmdInfoPtr->objProc;                  cmdPtr->objProc = cmdInfoPtr->objProc;
447                  cmdPtr->objClientData = (ClientData) NULL;                  cmdPtr->objClientData = (ClientData) NULL;
448              }              }
449              cmdPtr->deleteProc = NULL;              cmdPtr->deleteProc = NULL;
450              cmdPtr->deleteData = (ClientData) NULL;              cmdPtr->deleteData = (ClientData) NULL;
451              cmdPtr->deleted = 0;              cmdPtr->deleted = 0;
452              cmdPtr->importRefPtr = NULL;              cmdPtr->importRefPtr = NULL;
453              Tcl_SetHashValue(hPtr, cmdPtr);              Tcl_SetHashValue(hPtr, cmdPtr);
454          }          }
455      }      }
456    
457      /*      /*
458       * Register the builtin math functions.       * Register the builtin math functions.
459       */       */
460    
461      i = 0;      i = 0;
462      for (builtinFuncPtr = builtinFuncTable;  builtinFuncPtr->name != NULL;      for (builtinFuncPtr = builtinFuncTable;  builtinFuncPtr->name != NULL;
463              builtinFuncPtr++) {              builtinFuncPtr++) {
464          Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name,          Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name,
465                  builtinFuncPtr->numArgs, builtinFuncPtr->argTypes,                  builtinFuncPtr->numArgs, builtinFuncPtr->argTypes,
466                  (Tcl_MathProc *) NULL, (ClientData) 0);                  (Tcl_MathProc *) NULL, (ClientData) 0);
467          hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable,          hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable,
468                  builtinFuncPtr->name);                  builtinFuncPtr->name);
469          if (hPtr == NULL) {          if (hPtr == NULL) {
470              panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name);              panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name);
471              return NULL;              return NULL;
472          }          }
473          mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);          mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
474          mathFuncPtr->builtinFuncIndex = i;          mathFuncPtr->builtinFuncIndex = i;
475          i++;          i++;
476      }      }
477      iPtr->flags |= EXPR_INITIALIZED;      iPtr->flags |= EXPR_INITIALIZED;
478    
479      /*      /*
480       * Do Multiple/Safe Interps Tcl init stuff       * Do Multiple/Safe Interps Tcl init stuff
481       */       */
482    
483      TclInterpInit(interp);      TclInterpInit(interp);
484    
485      /*      /*
486       * We used to create the "errorInfo" and "errorCode" global vars at this       * We used to create the "errorInfo" and "errorCode" global vars at this
487       * point because so much of the Tcl implementation assumes they already       * point because so much of the Tcl implementation assumes they already
488       * exist. This is not quite enough, however, since they can be unset       * exist. This is not quite enough, however, since they can be unset
489       * at any time.       * at any time.
490       *       *
491       * There are 2 choices:       * There are 2 choices:
492       *    + Check every place where a GetVar of those is used       *    + Check every place where a GetVar of those is used
493       *      and the NULL result is not checked (like in tclLoad.c)       *      and the NULL result is not checked (like in tclLoad.c)
494       *    + Make SetVar,... NULL friendly       *    + Make SetVar,... NULL friendly
495       * We choose the second option because :       * We choose the second option because :
496       *    + It is easy and low cost to check for NULL pointer before       *    + It is easy and low cost to check for NULL pointer before
497       *      calling strlen()       *      calling strlen()
498       *    + It can be helpfull to other people using those API       *    + It can be helpfull to other people using those API
499       *    + Passing a NULL value to those closest 'meaning' is empty string       *    + Passing a NULL value to those closest 'meaning' is empty string
500       *      (specially with the new objects where 0 bytes strings are ok)       *      (specially with the new objects where 0 bytes strings are ok)
501       * So the following init is commented out:              -- dl       * So the following init is commented out:              -- dl
502       *       *
503       * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL,       * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL,
504       *       "", TCL_GLOBAL_ONLY);       *       "", TCL_GLOBAL_ONLY);
505       * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL,       * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL,
506       *       "NONE", TCL_GLOBAL_ONLY);       *       "NONE", TCL_GLOBAL_ONLY);
507       */       */
508    
509  #ifndef TCL_GENERIC_ONLY  #ifndef TCL_GENERIC_ONLY
510      TclSetupEnv(interp);      TclSetupEnv(interp);
511  #endif  #endif
512    
513      /*      /*
514       * Compute the byte order of this machine.       * Compute the byte order of this machine.
515       */       */
516    
517      order.s = 1;      order.s = 1;
518      Tcl_SetVar2(interp, "tcl_platform", "byteOrder",      Tcl_SetVar2(interp, "tcl_platform", "byteOrder",
519              ((order.c[0] == 1) ? "littleEndian" : "bigEndian"),              ((order.c[0] == 1) ? "littleEndian" : "bigEndian"),
520              TCL_GLOBAL_ONLY);              TCL_GLOBAL_ONLY);
521    
522      /*      /*
523       * Set up other variables such as tcl_version and tcl_library       * Set up other variables such as tcl_version and tcl_library
524       */       */
525    
526      Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);      Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
527      Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY);      Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY);
528      Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL,      Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL,
529              TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,              TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
530              TclPrecTraceProc, (ClientData) NULL);              TclPrecTraceProc, (ClientData) NULL);
531      TclpSetVariables(interp);      TclpSetVariables(interp);
532    
533  #ifdef TCL_THREADS  #ifdef TCL_THREADS
534      /*      /*
535       * The existence of the "threaded" element of the tcl_platform array indicates       * The existence of the "threaded" element of the tcl_platform array indicates
536       * that this particular Tcl shell has been compiled with threads turned on.       * that this particular Tcl shell has been compiled with threads turned on.
537       * Using "info exists tcl_platform(threaded)" a Tcl script can introspect on the       * Using "info exists tcl_platform(threaded)" a Tcl script can introspect on the
538       * interpreter level of thread safety.       * interpreter level of thread safety.
539       */       */
540    
541    
542      Tcl_SetVar2(interp, "tcl_platform", "threaded", "1",      Tcl_SetVar2(interp, "tcl_platform", "threaded", "1",
543              TCL_GLOBAL_ONLY);              TCL_GLOBAL_ONLY);
544  #endif  #endif
545    
546      /*      /*
547       * Register Tcl's version number.       * Register Tcl's version number.
548       */       */
549    
550      Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs);      Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs);
551            
552  #ifdef Tcl_InitStubs  #ifdef Tcl_InitStubs
553  #undef Tcl_InitStubs  #undef Tcl_InitStubs
554  #endif  #endif
555      Tcl_InitStubs(interp, TCL_VERSION, 1);      Tcl_InitStubs(interp, TCL_VERSION, 1);
556    
557      return interp;      return interp;
558  }  }
559    
560  /*  /*
561   *----------------------------------------------------------------------   *----------------------------------------------------------------------
562   *   *
563   * TclHideUnsafeCommands --   * TclHideUnsafeCommands --
564   *   *
565   *      Hides base commands that are not marked as safe from this   *      Hides base commands that are not marked as safe from this
566   *      interpreter.   *      interpreter.
567   *   *
568   * Results:   * Results:
569   *      TCL_OK if it succeeds, TCL_ERROR else.   *      TCL_OK if it succeeds, TCL_ERROR else.
570   *   *
571   * Side effects:   * Side effects:
572   *      Hides functionality in an interpreter.   *      Hides functionality in an interpreter.
573   *   *
574   *----------------------------------------------------------------------   *----------------------------------------------------------------------
575   */   */
576    
577  int  int
578  TclHideUnsafeCommands(interp)  TclHideUnsafeCommands(interp)
579      Tcl_Interp *interp;         /* Hide commands in this interpreter. */      Tcl_Interp *interp;         /* Hide commands in this interpreter. */
580  {  {
581      register CmdInfo *cmdInfoPtr;      register CmdInfo *cmdInfoPtr;
582    
583      if (interp == (Tcl_Interp *) NULL) {      if (interp == (Tcl_Interp *) NULL) {
584          return TCL_ERROR;          return TCL_ERROR;
585      }      }
586      for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {      for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
587          if (!cmdInfoPtr->isSafe) {          if (!cmdInfoPtr->isSafe) {
588              Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);              Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
589          }          }
590      }      }
591      return TCL_OK;      return TCL_OK;
592  }  }
593    
594  /*  /*
595   *--------------------------------------------------------------   *--------------------------------------------------------------
596   *   *
597   * Tcl_CallWhenDeleted --   * Tcl_CallWhenDeleted --
598   *   *
599   *      Arrange for a procedure to be called before a given   *      Arrange for a procedure to be called before a given
600   *      interpreter is deleted. The procedure is called as soon   *      interpreter is deleted. The procedure is called as soon
601   *      as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is   *      as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is
602   *      called on an interpreter that has already been deleted,   *      called on an interpreter that has already been deleted,
603   *      the procedure will be called when the last Tcl_Release is   *      the procedure will be called when the last Tcl_Release is
604   *      done on the interpreter.   *      done on the interpreter.
605   *   *
606   * Results:   * Results:
607   *      None.   *      None.
608   *   *
609   * Side effects:   * Side effects:
610   *      When Tcl_DeleteInterp is invoked to delete interp,   *      When Tcl_DeleteInterp is invoked to delete interp,
611   *      proc will be invoked.  See the manual entry for   *      proc will be invoked.  See the manual entry for
612   *      details.   *      details.
613   *   *
614   *--------------------------------------------------------------   *--------------------------------------------------------------
615   */   */
616    
617  void  void
618  Tcl_CallWhenDeleted(interp, proc, clientData)  Tcl_CallWhenDeleted(interp, proc, clientData)
619      Tcl_Interp *interp;         /* Interpreter to watch. */      Tcl_Interp *interp;         /* Interpreter to watch. */
620      Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter      Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
621                                   * is about to be deleted. */                                   * is about to be deleted. */
622      ClientData clientData;      /* One-word value to pass to proc. */      ClientData clientData;      /* One-word value to pass to proc. */
623  {  {
624      Interp *iPtr = (Interp *) interp;      Interp *iPtr = (Interp *) interp;
625      static int assocDataCounter = 0;      static int assocDataCounter = 0;
626  #ifdef TCL_THREADS  #ifdef TCL_THREADS
627      static Tcl_Mutex assocMutex;      static Tcl_Mutex assocMutex;
628  #endif  #endif
629      int new;      int new;
630      char buffer[32 + TCL_INTEGER_SPACE];      char buffer[32 + TCL_INTEGER_SPACE];
631      AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));      AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));
632      Tcl_HashEntry *hPtr;      Tcl_HashEntry *hPtr;
633    
634      Tcl_MutexLock(&assocMutex);      Tcl_MutexLock(&assocMutex);
635      sprintf(buffer, "Assoc Data Key #%d", assocDataCounter);      sprintf(buffer, "Assoc Data Key #%d", assocDataCounter);
636      assocDataCounter++;      assocDataCounter++;
637      Tcl_MutexUnlock(&assocMutex);      Tcl_MutexUnlock(&assocMutex);
638    
639      if (iPtr->assocData == (Tcl_HashTable *) NULL) {      if (iPtr->assocData == (Tcl_HashTable *) NULL) {
640          iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));          iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
641          Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);          Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
642      }      }
643      hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new);      hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new);
644      dPtr->proc = proc;      dPtr->proc = proc;
645      dPtr->clientData = clientData;      dPtr->clientData = clientData;
646      Tcl_SetHashValue(hPtr, dPtr);      Tcl_SetHashValue(hPtr, dPtr);
647  }  }
648    
649  /*  /*
650   *--------------------------------------------------------------   *--------------------------------------------------------------
651   *   *
652   * Tcl_DontCallWhenDeleted --   * Tcl_DontCallWhenDeleted --
653   *   *
654   *      Cancel the arrangement for a procedure to be called when   *      Cancel the arrangement for a procedure to be called when
655   *      a given interpreter is deleted.   *      a given interpreter is deleted.
656   *   *
657   * Results:   * Results:
658   *      None.   *      None.
659   *   *
660   * Side effects:   * Side effects:
661   *      If proc and clientData were previously registered as a   *      If proc and clientData were previously registered as a
662   *      callback via Tcl_CallWhenDeleted, they are unregistered.   *      callback via Tcl_CallWhenDeleted, they are unregistered.
663   *      If they weren't previously registered then nothing   *      If they weren't previously registered then nothing
664   *      happens.   *      happens.
665   *   *
666   *--------------------------------------------------------------   *--------------------------------------------------------------
667   */   */
668    
669  void  void
670  Tcl_DontCallWhenDeleted(interp, proc, clientData)  Tcl_DontCallWhenDeleted(interp, proc, clientData)
671      Tcl_Interp *interp;         /* Interpreter to watch. */      Tcl_Interp *interp;         /* Interpreter to watch. */
672      Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter      Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
673                                   * is about to be deleted. */                                   * is about to be deleted. */
674      ClientData clientData;      /* One-word value to pass to proc. */      ClientData clientData;      /* One-word value to pass to proc. */
675  {  {
676      Interp *iPtr = (Interp *) interp;      Interp *iPtr = (Interp *) interp;
677      Tcl_HashTable *hTablePtr;      Tcl_HashTable *hTablePtr;
678      Tcl_HashSearch hSearch;      Tcl_HashSearch hSearch;
679      Tcl_HashEntry *hPtr;      Tcl_HashEntry *hPtr;
680      AssocData *dPtr;      AssocData *dPtr;
681    
682      hTablePtr = iPtr->assocData;      hTablePtr = iPtr->assocData;
683      if (hTablePtr == (Tcl_HashTable *) NULL) {      if (hTablePtr == (Tcl_HashTable *) NULL) {
684          return;          return;
685      }      }
686      for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;      for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
687              hPtr = Tcl_NextHashEntry(&hSearch)) {              hPtr = Tcl_NextHashEntry(&hSearch)) {
688          dPtr = (AssocData *) Tcl_GetHashValue(hPtr);          dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
689          if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {          if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
690              ckfree((char *) dPtr);              ckfree((char *) dPtr);
691              Tcl_DeleteHashEntry(hPtr);              Tcl_DeleteHashEntry(hPtr);
692              return;              return;
693          }          }
694      }      }
695  }  }
696    
697  /*  /*
698   *----------------------------------------------------------------------   *----------------------------------------------------------------------
699   *   *
700   * Tcl_SetAssocData --   * Tcl_SetAssocData --
701   *   *
702   *      Creates a named association between user-specified data, a delete   *      Creates a named association between user-specified data, a delete
703   *      function and this interpreter. If the association already exists   *      function and this interpreter. If the association already exists
704   *      the data is overwritten with the new data. The delete function will   *      the data is overwritten with the new data. The delete function will
705   *      be invoked when the interpreter is deleted.   *      be invoked when the interpreter is deleted.
706   *   *
707   * Results:   * Results:
708   *      None.   *      None.
709   *   *
710   * Side effects:   * Side effects:
711   *      Sets the associated data, creates the association if needed.   *      Sets the associated data, creates the association if needed.
712   *   *
713   *----------------------------------------------------------------------   *----------------------------------------------------------------------
714   */   */
715    
716  void  void
717  Tcl_SetAssocData(interp, name, proc, clientData)  Tcl_SetAssocData(interp, name, proc, clientData)
718      Tcl_Interp *interp;         /* Interpreter to associate with. */      Tcl_Interp *interp;         /* Interpreter to associate with. */
719      char *name;                 /* Name for association. */      char *name;                 /* Name for association. */
720      Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is      Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is
721                                   * about to be deleted. */                                   * about to be deleted. */
722      ClientData clientData;      /* One-word value to pass to proc. */      ClientData clientData;      /* One-word value to pass to proc. */
723  {  {
724      Interp *iPtr = (Interp *) interp;      Interp *iPtr = (Interp *) interp;
725      AssocData *dPtr;      AssocData *dPtr;
726      Tcl_HashEntry *hPtr;      Tcl_HashEntry *hPtr;
727      int new;      int new;
728    
729      if (iPtr->assocData == (Tcl_HashTable *) NULL) {      if (iPtr->assocData == (Tcl_HashTable *) NULL) {
730          iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));          iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
731          Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);          Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
732      }      }
733      hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new);      hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new);
734      if (new == 0) {      if (new == 0) {
735          dPtr = (AssocData *) Tcl_GetHashValue(hPtr);          dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
736      } else {      } else {
737          dPtr = (AssocData *) ckalloc(sizeof(AssocData));          dPtr = (AssocData *) ckalloc(sizeof(AssocData));
738      }      }
739      dPtr->proc = proc;      dPtr->proc = proc;
740      dPtr->clientData = clientData;      dPtr->clientData = clientData;
741    
742      Tcl_SetHashValue(hPtr, dPtr);      Tcl_SetHashValue(hPtr, dPtr);
743  }  }
744    
745  /*  /*
746   *----------------------------------------------------------------------   *----------------------------------------------------------------------
747   *   *
748   * Tcl_DeleteAssocData --   * Tcl_DeleteAssocData --
749   *   *
750   *      Deletes a named association of user-specified data with   *      Deletes a named association of user-specified data with
751   *      the specified interpreter.   *      the specified interpreter.
752   *   *
753   * Results:   * Results:
754   *      None.   *      None.
755   *   *
756   * Side effects:   * Side effects:
757   *      Deletes the association.   *      Deletes the association.
758   *   *
759   *----------------------------------------------------------------------   *----------------------------------------------------------------------
760   */   */
761    
762  void  void
763  Tcl_DeleteAssocData(interp, name)  Tcl_DeleteAssocData(interp, name)
764      Tcl_Interp *interp;                 /* Interpreter to associate with. */      Tcl_Interp *interp;                 /* Interpreter to associate with. */
765      char *name;                         /* Name of association. */      char *name;                         /* Name of association. */
766  {  {
767      Interp *iPtr = (Interp *) interp;      Interp *iPtr = (Interp *) interp;
768      AssocData *dPtr;      AssocData *dPtr;
769      Tcl_HashEntry *hPtr;      Tcl_HashEntry *hPtr;
770    
771      if (iPtr->assocData == (Tcl_HashTable *) NULL) {      if (iPtr->assocData == (Tcl_HashTable *) NULL) {
772          return;          return;
773      }      }
774      hPtr = Tcl_FindHashEntry(iPtr->assocData, name);      hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
775      if (hPtr == (Tcl_HashEntry *) NULL) {      if (hPtr == (Tcl_HashEntry *) NULL) {
776          return;          return;
777      }      }
778      dPtr = (AssocData *) Tcl_GetHashValue(hPtr);      dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
779      if (dPtr->proc != NULL) {      if (dPtr->proc != NULL) {
780          (dPtr->proc) (dPtr->clientData, interp);          (dPtr->proc) (dPtr->clientData, interp);
781      }      }
782      ckfree((char *) dPtr);      ckfree((char *) dPtr);
783      Tcl_DeleteHashEntry(hPtr);      Tcl_DeleteHashEntry(hPtr);
784  }  }
785    
786  /*  /*
787   *----------------------------------------------------------------------   *----------------------------------------------------------------------
788   *   *
789   * Tcl_GetAssocData --   * Tcl_GetAssocData --
790   *   *
791   *      Returns the client data associated with this name in the   *      Returns the client data associated with this name in the
792   *      specified interpreter.   *      specified interpreter.
793   *   *
794   * Results:   * Results:
795   *      The client data in the AssocData record denoted by the named   *      The client data in the AssocData record denoted by the named
796   *      association, or NULL.   *      association, or NULL.
797   *   *
798   * Side effects:   * Side effects:
799   *      None.   *      None.
800   *   *
801   *----------------------------------------------------------------------   *----------------------------------------------------------------------
802   */   */
803    
804  ClientData  ClientData
805  Tcl_GetAssocData(interp, name, procPtr)  Tcl_GetAssocData(interp, name, procPtr)
806      Tcl_Interp *interp;                 /* Interpreter associated with. */      Tcl_Interp *interp;                 /* Interpreter associated with. */
807      char *name;                         /* Name of association. */      char *name;                         /* Name of association. */
808      Tcl_InterpDeleteProc **procPtr;     /* Pointer to place to store address      Tcl_InterpDeleteProc **procPtr;     /* Pointer to place to store address
809                                           * of current deletion callback. */                                           * of current deletion callback. */
810  {  {
811      Interp *iPtr = (Interp *) interp;      Interp *iPtr = (Interp *) interp;
812      AssocData *dPtr;      AssocData *dPtr;
813      Tcl_HashEntry *hPtr;      Tcl_HashEntry *hPtr;
814    
815      if (iPtr->assocData == (Tcl_HashTable *) NULL) {      if (iPtr->assocData == (Tcl_HashTable *) NULL) {
816          return (ClientData) NULL;          return (ClientData) NULL;
817      }      }
818      hPtr = Tcl_FindHashEntry(iPtr->assocData, name);      hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
819      if (hPtr == (Tcl_HashEntry *) NULL) {      if (hPtr == (Tcl_HashEntry *) NULL) {
820          return (ClientData) NULL;          return (ClientData) NULL;
821      }      }
822      dPtr = (AssocData *) Tcl_GetHashValue(hPtr);      dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
823      if (procPtr != (Tcl_InterpDeleteProc **) NULL) {      if (procPtr != (Tcl_InterpDeleteProc **) NULL) {
824          *procPtr = dPtr->proc;          *procPtr = dPtr->proc;
825      }      }
826      return dPtr->clientData;      return dPtr->clientData;
827  }  }
828    
829  /*  /*
830   *----------------------------------------------------------------------   *----------------------------------------------------------------------
831   *   *
832   * Tcl_InterpDeleted --   * Tcl_InterpDeleted --
833   *   *
834   *      Returns nonzero if the interpreter has been deleted with a call   *      Returns nonzero if the interpreter has been deleted with a call
835   *      to Tcl_DeleteInterp.   *      to Tcl_DeleteInterp.
836   *   *
837   * Results:   * Results:
838   *      Nonzero if the interpreter is deleted, zero otherwise.   *      Nonzero if the interpreter is deleted, zero otherwise.
839   *   *
840   * Side effects:   * Side effects:
841   *      None.   *      None.
842   *   *
843   *----------------------------------------------------------------------   *----------------------------------------------------------------------
844   */   */
845    
846  int  int
847  Tcl_InterpDeleted(interp)  Tcl_InterpDeleted(interp)
848      Tcl_Interp *interp;      Tcl_Interp *interp;
849  {  {
850      return (((Interp *) interp)->flags & DELETED) ? 1 : 0;      return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
851  }  }
852    
853  /*  /*
854   *----------------------------------------------------------------------   *----------------------------------------------------------------------
855   *   *
856   * Tcl_DeleteInterp --   * Tcl_DeleteInterp --
857   *   *
858   *      Ensures that the interpreter will be deleted eventually. If there   *      Ensures that the interpreter will be deleted eventually. If there
859   *      are no Tcl_Preserve calls in effect for this interpreter, it is   *      are no Tcl_Preserve calls in effect for this interpreter, it is
860   *      deleted immediately, otherwise the interpreter is deleted when   *      deleted immediately, otherwise the interpreter is deleted when
861   *      the last Tcl_Preserve is matched by a call to Tcl_Release. In either   *      the last Tcl_Preserve is matched by a call to Tcl_Release. In either
862   *      case, the procedure runs the currently registered deletion callbacks.   *      case, the procedure runs the currently registered deletion callbacks.
863   *   *
864   * Results:   * Results:
865   *      None.   *      None.
866   *   *
867   * Side effects:   * Side effects:
868   *      The interpreter is marked as deleted. The caller may still use it   *      The interpreter is marked as deleted. The caller may still use it
869   *      safely if there are calls to Tcl_Preserve in effect for the   *      safely if there are calls to Tcl_Preserve in effect for the
870   *      interpreter, but further calls to Tcl_Eval etc in this interpreter   *      interpreter, but further calls to Tcl_Eval etc in this interpreter
871   *      will fail.   *      will fail.
872   *   *
873   *----------------------------------------------------------------------   *----------------------------------------------------------------------
874   */   */
875    
876  void  void
877  Tcl_DeleteInterp(interp)  Tcl_DeleteInterp(interp)
878      Tcl_Interp *interp;         /* Token for command interpreter (returned      Tcl_Interp *interp;         /* Token for command interpreter (returned
879                                   * by a previous call to Tcl_CreateInterp). */                                   * by a previous call to Tcl_CreateInterp). */
880  {  {
881      Interp *iPtr = (Interp *) interp;      Interp *iPtr = (Interp *) interp;
882    
883      /*      /*
884       * If the interpreter has already been marked deleted, just punt.       * If the interpreter has already been marked deleted, just punt.
885       */       */
886    
887      if (iPtr->flags & DELETED) {      if (iPtr->flags & DELETED) {
888          return;          return;
889      }      }
890            
891      /*      /*
892       * Mark the interpreter as deleted. No further evals will be allowed.       * Mark the interpreter as deleted. No further evals will be allowed.
893       */       */
894    
895      iPtr->flags |= DELETED;      iPtr->flags |= DELETED;
896    
897      /*      /*
898       * Ensure that the interpreter is eventually deleted.       * Ensure that the interpreter is eventually deleted.
899       */       */
900    
901      Tcl_EventuallyFree((ClientData) interp,      Tcl_EventuallyFree((ClientData) interp,
902              (Tcl_FreeProc *) DeleteInterpProc);              (Tcl_FreeProc *) DeleteInterpProc);
903  }  }
904    
905  /*  /*
906   *----------------------------------------------------------------------   *----------------------------------------------------------------------
907   *   *
908   * DeleteInterpProc --   * DeleteInterpProc --
909   *   *
910   *      Helper procedure to delete an interpreter. This procedure is   *      Helper procedure to delete an interpreter. This procedure is
911   *      called when the last call to Tcl_Preserve on this interpreter   *      called when the last call to Tcl_Preserve on this interpreter
912   *      is matched by a call to Tcl_Release. The procedure cleans up   *      is matched by a call to Tcl_Release. The procedure cleans up
913   *      all resources used in the interpreter and calls all currently   *      all resources used in the interpreter and calls all currently
914   *      registered interpreter deletion callbacks.   *      registered interpreter deletion callbacks.
915   *   *
916   * Results:   * Results:
917   *      None.   *      None.
918   *   *
919   * Side effects:   * Side effects:
920   *      Whatever the interpreter deletion callbacks do. Frees resources   *      Whatever the interpreter deletion callbacks do. Frees resources
921   *      used by the interpreter.   *      used by the interpreter.
922   *   *
923   *----------------------------------------------------------------------   *----------------------------------------------------------------------
924   */   */
925    
926  static void  static void
927  DeleteInterpProc(interp)  DeleteInterpProc(interp)
928      Tcl_Interp *interp;                 /* Interpreter to delete. */      Tcl_Interp *interp;                 /* Interpreter to delete. */
929  {  {
930      Interp *iPtr = (Interp *) interp;      Interp *iPtr = (Interp *) interp;
931      Tcl_HashEntry *hPtr;      Tcl_HashEntry *hPtr;
932      Tcl_HashSearch search;      Tcl_HashSearch search;
933      Tcl_HashTable *hTablePtr;      Tcl_HashTable *hTablePtr;
934      ResolverScheme *resPtr, *nextResPtr;      ResolverScheme *resPtr, *nextResPtr;
935    
936      /*      /*
937       * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.       * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
938       */       */
939            
940      if (iPtr->numLevels > 0) {      if (iPtr->numLevels > 0) {
941          panic("DeleteInterpProc called with active evals");          panic("DeleteInterpProc called with active evals");
942      }      }
943    
944      /*      /*
945       * The interpreter should already be marked deleted; otherwise how       * The interpreter should already be marked deleted; otherwise how
946       * did we get here?       * did we get here?
947       */       */
948    
949      if (!(iPtr->flags & DELETED)) {      if (!(iPtr->flags & DELETED)) {
950          panic("DeleteInterpProc called on interpreter not marked deleted");          panic("DeleteInterpProc called on interpreter not marked deleted");
951      }      }
952    
953      TclHandleFree(iPtr->handle);      TclHandleFree(iPtr->handle);
954    
955      /*      /*
956       * Dismantle everything in the global namespace except for the       * Dismantle everything in the global namespace except for the
957       * "errorInfo" and "errorCode" variables. These remain until the       * "errorInfo" and "errorCode" variables. These remain until the
958       * namespace is actually destroyed, in case any errors occur.       * namespace is actually destroyed, in case any errors occur.
959       *         *  
960       * Dismantle the namespace here, before we clear the assocData. If any       * Dismantle the namespace here, before we clear the assocData. If any
961       * background errors occur here, they will be deleted below.       * background errors occur here, they will be deleted below.
962       */       */
963            
964      TclTeardownNamespace(iPtr->globalNsPtr);      TclTeardownNamespace(iPtr->globalNsPtr);
965    
966      /*      /*
967       * Delete all the hidden commands.       * Delete all the hidden commands.
968       */       */
969            
970      hTablePtr = iPtr->hiddenCmdTablePtr;      hTablePtr = iPtr->hiddenCmdTablePtr;
971      if (hTablePtr != NULL) {      if (hTablePtr != NULL) {
972          /*          /*
973           * Non-pernicious deletion.  The deletion callbacks will not be           * Non-pernicious deletion.  The deletion callbacks will not be
974           * allowed to create any new hidden or non-hidden commands.           * allowed to create any new hidden or non-hidden commands.
975           * Tcl_DeleteCommandFromToken() will remove the entry from the           * Tcl_DeleteCommandFromToken() will remove the entry from the
976           * hiddenCmdTablePtr.           * hiddenCmdTablePtr.
977           */           */
978                    
979          hPtr = Tcl_FirstHashEntry(hTablePtr, &search);          hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
980          for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {          for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
981              Tcl_DeleteCommandFromToken(interp,              Tcl_DeleteCommandFromToken(interp,
982                      (Tcl_Command) Tcl_GetHashValue(hPtr));                      (Tcl_Command) Tcl_GetHashValue(hPtr));
983          }          }
984          Tcl_DeleteHashTable(hTablePtr);          Tcl_DeleteHashTable(hTablePtr);
985          ckfree((char *) hTablePtr);          ckfree((char *) hTablePtr);
986      }      }
987      /*      /*
988       * Tear down the math function table.       * Tear down the math function table.
989       */       */
990    
991      for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search);      for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search);
992               hPtr != NULL;               hPtr != NULL;
993               hPtr = Tcl_NextHashEntry(&search)) {               hPtr = Tcl_NextHashEntry(&search)) {
994          ckfree((char *) Tcl_GetHashValue(hPtr));          ckfree((char *) Tcl_GetHashValue(hPtr));
995      }      }
996      Tcl_DeleteHashTable(&iPtr->mathFuncTable);      Tcl_DeleteHashTable(&iPtr->mathFuncTable);
997    
998      /*      /*
999       * Invoke deletion callbacks; note that a callback can create new       * Invoke deletion callbacks; note that a callback can create new
1000       * callbacks, so we iterate.       * callbacks, so we iterate.
1001       */       */
1002    
1003      while (iPtr->assocData != (Tcl_HashTable *) NULL) {      while (iPtr->assocData != (Tcl_HashTable *) NULL) {
1004          AssocData *dPtr;          AssocData *dPtr;
1005                    
1006          hTablePtr = iPtr->assocData;          hTablePtr = iPtr->assocData;
1007          iPtr->assocData = (Tcl_HashTable *) NULL;          iPtr->assocData = (Tcl_HashTable *) NULL;
1008          for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);          for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
1009                   hPtr != NULL;                   hPtr != NULL;
1010                   hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {                   hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
1011              dPtr = (AssocData *) Tcl_GetHashValue(hPtr);              dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
1012              Tcl_DeleteHashEntry(hPtr);              Tcl_DeleteHashEntry(hPtr);
1013              if (dPtr->proc != NULL) {              if (dPtr->proc != NULL) {
1014                  (*dPtr->proc)(dPtr->clientData, interp);                  (*dPtr->proc)(dPtr->clientData, interp);
1015              }              }
1016              ckfree((char *) dPtr);              ckfree((char *) dPtr);
1017          }          }
1018          Tcl_DeleteHashTable(hTablePtr);          Tcl_DeleteHashTable(hTablePtr);
1019          ckfree((char *) hTablePtr);          ckfree((char *) hTablePtr);
1020      }      }
1021    
1022      /*      /*
1023       * Finish deleting the global namespace.       * Finish deleting the global namespace.
1024       */       */
1025            
1026      Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);      Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);
1027    
1028      /*      /*
1029       * Free up the result *after* deleting variables, since variable       * Free up the result *after* deleting variables, since variable
1030       * deletion could have transferred ownership of the result string       * deletion could have transferred ownership of the result string
1031       * to Tcl.       * to Tcl.
1032       */       */
1033    
1034      Tcl_FreeResult(interp);      Tcl_FreeResult(interp);
1035      interp->result = NULL;      interp->result = NULL;
1036      Tcl_DecrRefCount(iPtr->objResultPtr);      Tcl_DecrRefCount(iPtr->objResultPtr);
1037      iPtr->objResultPtr = NULL;      iPtr->objResultPtr = NULL;
1038      if (iPtr->errorInfo != NULL) {      if (iPtr->errorInfo != NULL) {
1039          ckfree(iPtr->errorInfo);          ckfree(iPtr->errorInfo);
1040          iPtr->errorInfo = NULL;          iPtr->errorInfo = NULL;
1041      }      }
1042      if (iPtr->errorCode != NULL) {      if (iPtr->errorCode != NULL) {
1043          ckfree(iPtr->errorCode);          ckfree(iPtr->errorCode);
1044          iPtr->errorCode = NULL;          iPtr->errorCode = NULL;
1045      }      }
1046      if (iPtr->appendResult != NULL) {      if (iPtr->appendResult != NULL) {
1047          ckfree(iPtr->appendResult);          ckfree(iPtr->appendResult);
1048          iPtr->appendResult = NULL;          iPtr->appendResult = NULL;
1049      }      }
1050      TclFreePackageInfo(iPtr);      TclFreePackageInfo(iPtr);
1051      while (iPtr->tracePtr != NULL) {      while (iPtr->tracePtr != NULL) {
1052          Trace *nextPtr = iPtr->tracePtr->nextPtr;          Trace *nextPtr = iPtr->tracePtr->nextPtr;
1053    
1054          ckfree((char *) iPtr->tracePtr);          ckfree((char *) iPtr->tracePtr);
1055          iPtr->tracePtr = nextPtr;          iPtr->tracePtr = nextPtr;
1056      }      }
1057      if (iPtr->execEnvPtr != NULL) {      if (iPtr->execEnvPtr != NULL) {
1058          TclDeleteExecEnv(iPtr->execEnvPtr);          TclDeleteExecEnv(iPtr->execEnvPtr);
1059      }      }
1060      Tcl_DecrRefCount(iPtr->emptyObjPtr);      Tcl_DecrRefCount(iPtr->emptyObjPtr);
1061      iPtr->emptyObjPtr = NULL;      iPtr->emptyObjPtr = NULL;
1062    
1063      resPtr = iPtr->resolverPtr;      resPtr = iPtr->resolverPtr;
1064      while (resPtr) {      while (resPtr) {
1065          nextResPtr = resPtr->nextPtr;          nextResPtr = resPtr->nextPtr;
1066          ckfree(resPtr->name);          ckfree(resPtr->name);
1067          ckfree((char *) resPtr);          ckfree((char *) resPtr);
1068          resPtr = nextResPtr;          resPtr = nextResPtr;
1069      }      }
1070            
1071      /*      /*
1072       * Free up literal objects created for scripts compiled by the       * Free up literal objects created for scripts compiled by the
1073       * interpreter.       * interpreter.
1074       */       */
1075    
1076      TclDeleteLiteralTable(interp, &(iPtr->literalTable));      TclDeleteLiteralTable(interp, &(iPtr->literalTable));
1077      ckfree((char *) iPtr);      ckfree((char *) iPtr);
1078  }  }
1079    
1080  /*  /*
1081   *---------------------------------------------------------------------------   *---------------------------------------------------------------------------
1082   *   *
1083   * Tcl_HideCommand --   * Tcl_HideCommand --
1084   *   *
1085   *      Makes a command hidden so that it cannot be invoked from within   *      Makes a command hidden so that it cannot be invoked from within
1086   *      an interpreter, only from within an ancestor.   *      an interpreter, only from within an ancestor.
1087   *   *
1088   * Results:   * Results:
1089   *      A standard Tcl result; also leaves a message in the interp's result   *      A standard Tcl result; also leaves a message in the interp's result
1090   *      if an error occurs.   *      if an error occurs.
1091   *   *
1092   * Side effects:   * Side effects:
1093   *      Removes a command from the command table and create an entry   *      Removes a command from the command table and create an entry
1094   *      into the hidden command table under the specified token name.   *      into the hidden command table under the specified token name.
1095   *   *
1096   *---------------------------------------------------------------------------   *---------------------------------------------------------------------------
1097   */   */
1098    
1099  int  int
1100  Tcl_HideCommand(interp, cmdName, hiddenCmdToken)  Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
1101      Tcl_Interp *interp;         /* Interpreter in which to hide command. */      Tcl_Interp *interp;         /* Interpreter in which to hide command. */
1102      char *cmdName;              /* Name of command to hide. */      char *cmdName;              /* Name of command to hide. */
1103      char *hiddenCmdToken;       /* Token name of the to-be-hidden command. */      char *hiddenCmdToken;       /* Token name of the to-be-hidden command. */
1104  {  {
1105      Interp *iPtr = (Interp *) interp;      Interp *iPtr = (Interp *) interp;
1106      Tcl_Command cmd;      Tcl_Command cmd;
1107      Command *cmdPtr;      Command *cmdPtr;
1108      Tcl_HashTable *hiddenCmdTablePtr;      Tcl_HashTable *hiddenCmdTablePtr;
1109      Tcl_HashEntry *hPtr;      Tcl_HashEntry *hPtr;
1110      int new;      int new;
1111    
1112      if (iPtr->flags & DELETED) {      if (iPtr->flags & DELETED) {
1113    
1114          /*          /*
1115           * The interpreter is being deleted. Do not create any new           * The interpreter is being deleted. Do not create any new
1116           * structures, because it is not safe to modify the interpreter.           * structures, because it is not safe to modify the interpreter.
1117           */           */
1118                    
1119          return TCL_ERROR;          return TCL_ERROR;
1120      }      }
1121    
1122      /*      /*
1123       * Disallow hiding of commands that are currently in a namespace or       * Disallow hiding of commands that are currently in a namespace or
1124       * renaming (as part of hiding) into a namespace.       * renaming (as part of hiding) into a namespace.
1125       *       *
1126       * (because the current implementation with a single global table       * (because the current implementation with a single global table
1127       *  and the needed uniqueness of names cause problems with namespaces)       *  and the needed uniqueness of names cause problems with namespaces)
1128       *       *
1129       * we don't need to check for "::" in cmdName because the real check is       * we don't need to check for "::" in cmdName because the real check is
1130       * on the nsPtr below.       * on the nsPtr below.
1131       *       *
1132       * hiddenCmdToken is just a string which is not interpreted in any way.       * hiddenCmdToken is just a string which is not interpreted in any way.
1133       * It may contain :: but the string is not interpreted as a namespace       * It may contain :: but the string is not interpreted as a namespace
1134       * qualifier command name. Thus, hiding foo::bar to foo::bar and then       * qualifier command name. Thus, hiding foo::bar to foo::bar and then
1135       * trying to expose or invoke ::foo::bar will NOT work; but if the       * trying to expose or invoke ::foo::bar will NOT work; but if the
1136       * application always uses the same strings it will get consistent       * application always uses the same strings it will get consistent
1137       * behaviour.       * behaviour.
1138       *       *
1139       * But as we currently limit ourselves to the global namespace only       * But as we currently limit ourselves to the global namespace only
1140       * for the source, in order to avoid potential confusion,       * for the source, in order to avoid potential confusion,
1141       * lets prevent "::" in the token too.  --dl       * lets prevent "::" in the token too.  --dl
1142       */       */
1143    
1144      if (strstr(hiddenCmdToken, "::") != NULL) {      if (strstr(hiddenCmdToken, "::") != NULL) {
1145          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1146                  "cannot use namespace qualifiers as hidden command",                  "cannot use namespace qualifiers as hidden command",
1147                  "token (rename)", (char *) NULL);                  "token (rename)", (char *) NULL);
1148          return TCL_ERROR;          return TCL_ERROR;
1149      }      }
1150    
1151      /*      /*
1152       * Find the command to hide. An error is returned if cmdName can't       * Find the command to hide. An error is returned if cmdName can't
1153       * be found. Look up the command only from the global namespace.       * be found. Look up the command only from the global namespace.
1154       * Full path of the command must be given if using namespaces.       * Full path of the command must be given if using namespaces.
1155       */       */
1156    
1157      cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,      cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
1158              /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY);              /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY);
1159      if (cmd == (Tcl_Command) NULL) {      if (cmd == (Tcl_Command) NULL) {
1160          return TCL_ERROR;          return TCL_ERROR;
1161      }      }
1162      cmdPtr = (Command *) cmd;      cmdPtr = (Command *) cmd;
1163    
1164      /*      /*
1165       * Check that the command is really in global namespace       * Check that the command is really in global namespace
1166       */       */
1167    
1168      if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {      if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
1169          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1170                  "can only hide global namespace commands",                  "can only hide global namespace commands",
1171                  " (use rename then hide)", (char *) NULL);                  " (use rename then hide)", (char *) NULL);
1172          return TCL_ERROR;          return TCL_ERROR;
1173      }      }
1174            
1175      /*      /*
1176       * Initialize the hidden command table if necessary.       * Initialize the hidden command table if necessary.
1177       */       */
1178    
1179      hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;      hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
1180      if (hiddenCmdTablePtr == NULL) {      if (hiddenCmdTablePtr == NULL) {
1181          hiddenCmdTablePtr = (Tcl_HashTable *)          hiddenCmdTablePtr = (Tcl_HashTable *)
1182                  ckalloc((unsigned) sizeof(Tcl_HashTable));                  ckalloc((unsigned) sizeof(Tcl_HashTable));
1183          Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS);          Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS);
1184          iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr;          iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr;
1185      }      }
1186    
1187      /*      /*
1188       * It is an error to move an exposed command to a hidden command with       * It is an error to move an exposed command to a hidden command with
1189       * hiddenCmdToken if a hidden command with the name hiddenCmdToken already       * hiddenCmdToken if a hidden command with the name hiddenCmdToken already
1190       * exists.       * exists.
1191       */       */
1192            
1193      hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new);      hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new);
1194      if (!new) {      if (!new) {
1195          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1196                  "hidden command named \"", hiddenCmdToken, "\" already exists",                  "hidden command named \"", hiddenCmdToken, "\" already exists",
1197                  (char *) NULL);                  (char *) NULL);
1198          return TCL_ERROR;          return TCL_ERROR;
1199      }      }
1200    
1201      /*      /*
1202       * Nb : This code is currently 'like' a rename to a specialy set apart       * Nb : This code is currently 'like' a rename to a specialy set apart
1203       * name table. Changes here and in TclRenameCommand must       * name table. Changes here and in TclRenameCommand must
1204       * be kept in synch untill the common parts are actually       * be kept in synch untill the common parts are actually
1205       * factorized out.       * factorized out.
1206       */       */
1207    
1208      /*      /*
1209       * Remove the hash entry for the command from the interpreter command       * Remove the hash entry for the command from the interpreter command
1210       * table. This is like deleting the command, so bump its command epoch;       * table. This is like deleting the command, so bump its command epoch;
1211       * this invalidates any cached references that point to the command.       * this invalidates any cached references that point to the command.
1212       */       */
1213    
1214      if (cmdPtr->hPtr != NULL) {      if (cmdPtr->hPtr != NULL) {
1215          Tcl_DeleteHashEntry(cmdPtr->hPtr);          Tcl_DeleteHashEntry(cmdPtr->hPtr);
1216          cmdPtr->hPtr = (Tcl_HashEntry *) NULL;          cmdPtr->hPtr = (Tcl_HashEntry *) NULL;
1217          cmdPtr->cmdEpoch++;          cmdPtr->cmdEpoch++;
1218      }      }
1219    
1220      /*      /*
1221       * Now link the hash table entry with the command structure.       * Now link the hash table entry with the command structure.
1222       * We ensured above that the nsPtr was right.       * We ensured above that the nsPtr was right.
1223       */       */
1224            
1225      cmdPtr->hPtr = hPtr;      cmdPtr->hPtr = hPtr;
1226      Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);      Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
1227    
1228      /*      /*
1229       * If the command being hidden has a compile procedure, increment the       * If the command being hidden has a compile procedure, increment the
1230       * interpreter's compileEpoch to invalidate its compiled code. This       * interpreter's compileEpoch to invalidate its compiled code. This
1231       * makes sure that we don't later try to execute old code compiled with       * makes sure that we don't later try to execute old code compiled with
1232       * command-specific (i.e., inline) bytecodes for the now-hidden       * command-specific (i.e., inline) bytecodes for the now-hidden
1233       * command. This field is checked in Tcl_EvalObj and ObjInterpProc,       * command. This field is checked in Tcl_EvalObj and ObjInterpProc,
1234       * and code whose compilation epoch doesn't match is recompiled.       * and code whose compilation epoch doesn't match is recompiled.
1235       */       */
1236    
1237      if (cmdPtr->compileProc != NULL) {      if (cmdPtr->compileProc != NULL) {
1238          iPtr->compileEpoch++;          iPtr->compileEpoch++;
1239      }      }
1240      return TCL_OK;      return TCL_OK;
1241  }  }
1242    
1243  /*  /*
1244   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1245   *   *
1246   * Tcl_ExposeCommand --   * Tcl_ExposeCommand --
1247   *   *
1248   *      Makes a previously hidden command callable from inside the   *      Makes a previously hidden command callable from inside the
1249   *      interpreter instead of only by its ancestors.   *      interpreter instead of only by its ancestors.
1250   *   *
1251   * Results:   * Results:
1252   *      A standard Tcl result. If an error occurs, a message is left   *      A standard Tcl result. If an error occurs, a message is left
1253   *      in the interp's result.   *      in the interp's result.
1254   *   *
1255   * Side effects:   * Side effects:
1256   *      Moves commands from one hash table to another.   *      Moves commands from one hash table to another.
1257   *   *
1258   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1259   */   */
1260    
1261  int  int
1262  Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)  Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
1263      Tcl_Interp *interp;         /* Interpreter in which to make command      Tcl_Interp *interp;         /* Interpreter in which to make command
1264                                   * callable. */                                   * callable. */
1265      char *hiddenCmdToken;       /* Name of hidden command. */      char *hiddenCmdToken;       /* Name of hidden command. */
1266      char *cmdName;              /* Name of to-be-exposed command. */      char *cmdName;              /* Name of to-be-exposed command. */
1267  {  {
1268      Interp *iPtr = (Interp *) interp;      Interp *iPtr = (Interp *) interp;
1269      Command *cmdPtr;      Command *cmdPtr;
1270      Namespace *nsPtr;      Namespace *nsPtr;
1271      Tcl_HashEntry *hPtr;      Tcl_HashEntry *hPtr;
1272      Tcl_HashTable *hiddenCmdTablePtr;      Tcl_HashTable *hiddenCmdTablePtr;
1273      int new;      int new;
1274    
1275      if (iPtr->flags & DELETED) {      if (iPtr->flags & DELETED) {
1276          /*          /*
1277           * The interpreter is being deleted. Do not create any new           * The interpreter is being deleted. Do not create any new
1278           * structures, because it is not safe to modify the interpreter.           * structures, because it is not safe to modify the interpreter.
1279           */           */
1280                    
1281          return TCL_ERROR;          return TCL_ERROR;
1282      }      }
1283    
1284      /*      /*
1285       * Check that we have a regular name for the command       * Check that we have a regular name for the command
1286       * (that the user is not trying to do an expose and a rename       * (that the user is not trying to do an expose and a rename
1287       *  (to another namespace) at the same time)       *  (to another namespace) at the same time)
1288       */       */
1289    
1290      if (strstr(cmdName, "::") != NULL) {      if (strstr(cmdName, "::") != NULL) {
1291          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1292                  "can not expose to a namespace ",                  "can not expose to a namespace ",
1293                  "(use expose to toplevel, then rename)",                  "(use expose to toplevel, then rename)",
1294                   (char *) NULL);                   (char *) NULL);
1295          return TCL_ERROR;          return TCL_ERROR;
1296      }      }
1297    
1298      /*      /*
1299       * Get the command from the hidden command table:       * Get the command from the hidden command table:
1300       */       */
1301    
1302      hPtr = NULL;      hPtr = NULL;
1303      hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;      hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
1304      if (hiddenCmdTablePtr != NULL) {      if (hiddenCmdTablePtr != NULL) {
1305          hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken);          hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken);
1306      }      }
1307      if (hPtr == (Tcl_HashEntry *) NULL) {      if (hPtr == (Tcl_HashEntry *) NULL) {
1308          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1309                  "unknown hidden command \"", hiddenCmdToken,                  "unknown hidden command \"", hiddenCmdToken,
1310                  "\"", (char *) NULL);                  "\"", (char *) NULL);
1311          return TCL_ERROR;          return TCL_ERROR;
1312      }      }
1313      cmdPtr = (Command *) Tcl_GetHashValue(hPtr);      cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
1314            
1315    
1316      /*      /*
1317       * Check that we have a true global namespace       * Check that we have a true global namespace
1318       * command (enforced by Tcl_HideCommand() but let's double       * command (enforced by Tcl_HideCommand() but let's double
1319       * check. (If it was not, we would not really know how to       * check. (If it was not, we would not really know how to
1320       * handle it).       * handle it).
1321       */       */
1322      if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {      if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
1323          /*          /*
1324           * This case is theoritically impossible,           * This case is theoritically impossible,
1325           * we might rather panic() than 'nicely' erroring out ?           * we might rather panic() than 'nicely' erroring out ?
1326           */           */
1327          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1328                  "trying to expose a non global command name space command",                  "trying to expose a non global command name space command",
1329                  (char *) NULL);                  (char *) NULL);
1330          return TCL_ERROR;          return TCL_ERROR;
1331      }      }
1332            
1333      /* This is the global table */      /* This is the global table */
1334      nsPtr = cmdPtr->nsPtr;      nsPtr = cmdPtr->nsPtr;
1335    
1336      /*      /*
1337       * It is an error to overwrite an existing exposed command as a result       * It is an error to overwrite an existing exposed command as a result
1338       * of exposing a previously hidden command.       * of exposing a previously hidden command.
1339       */       */
1340    
1341      hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new);      hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new);
1342      if (!new) {      if (!new) {
1343          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1344                  "exposed command \"", cmdName,                  "exposed command \"", cmdName,
1345                  "\" already exists", (char *) NULL);                  "\" already exists", (char *) NULL);
1346          return TCL_ERROR;          return TCL_ERROR;
1347      }      }
1348    
1349      /*      /*
1350       * Remove the hash entry for the command from the interpreter hidden       * Remove the hash entry for the command from the interpreter hidden
1351       * command table.       * command table.
1352       */       */
1353    
1354      if (cmdPtr->hPtr != NULL) {      if (cmdPtr->hPtr != NULL) {
1355          Tcl_DeleteHashEntry(cmdPtr->hPtr);          Tcl_DeleteHashEntry(cmdPtr->hPtr);
1356          cmdPtr->hPtr = NULL;          cmdPtr->hPtr = NULL;
1357      }      }
1358    
1359      /*      /*
1360       * Now link the hash table entry with the command structure.       * Now link the hash table entry with the command structure.
1361       * This is like creating a new command, so deal with any shadowing       * This is like creating a new command, so deal with any shadowing
1362       * of commands in the global namespace.       * of commands in the global namespace.
1363       */       */
1364            
1365      cmdPtr->hPtr = hPtr;      cmdPtr->hPtr = hPtr;
1366    
1367      Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);      Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
1368    
1369      /*      /*
1370       * Not needed as we are only in the global namespace       * Not needed as we are only in the global namespace
1371       * (but would be needed again if we supported namespace command hiding)       * (but would be needed again if we supported namespace command hiding)
1372       *       *
1373       * TclResetShadowedCmdRefs(interp, cmdPtr);       * TclResetShadowedCmdRefs(interp, cmdPtr);
1374       */       */
1375    
1376    
1377      /*      /*
1378       * If the command being exposed has a compile procedure, increment       * If the command being exposed has a compile procedure, increment
1379       * interpreter's compileEpoch to invalidate its compiled code. This       * interpreter's compileEpoch to invalidate its compiled code. This
1380       * makes sure that we don't later try to execute old code compiled       * makes sure that we don't later try to execute old code compiled
1381       * assuming the command is hidden. This field is checked in Tcl_EvalObj       * assuming the command is hidden. This field is checked in Tcl_EvalObj
1382       * and ObjInterpProc, and code whose compilation epoch doesn't match is       * and ObjInterpProc, and code whose compilation epoch doesn't match is
1383       * recompiled.       * recompiled.
1384       */       */
1385    
1386      if (cmdPtr->compileProc != NULL) {      if (cmdPtr->compileProc != NULL) {
1387          iPtr->compileEpoch++;          iPtr->compileEpoch++;
1388      }      }
1389      return TCL_OK;      return TCL_OK;
1390  }  }
1391    
1392  /*  /*
1393   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1394   *   *
1395   * Tcl_CreateCommand --   * Tcl_CreateCommand --
1396   *   *
1397   *      Define a new command in a command table.   *      Define a new command in a command table.
1398   *   *
1399   * Results:   * Results:
1400   *      The return value is a token for the command, which can   *      The return value is a token for the command, which can
1401   *      be used in future calls to Tcl_GetCommandName.   *      be used in future calls to Tcl_GetCommandName.
1402   *   *
1403   * Side effects:   * Side effects:
1404   *      If a command named cmdName already exists for interp, it is deleted.   *      If a command named cmdName already exists for interp, it is deleted.
1405   *      In the future, when cmdName is seen as the name of a command by   *      In the future, when cmdName is seen as the name of a command by
1406   *      Tcl_Eval, proc will be called. To support the bytecode interpreter,   *      Tcl_Eval, proc will be called. To support the bytecode interpreter,
1407   *      the command is created with a wrapper Tcl_ObjCmdProc   *      the command is created with a wrapper Tcl_ObjCmdProc
1408   *      (TclInvokeStringCommand) that eventially calls proc. When the   *      (TclInvokeStringCommand) that eventially calls proc. When the
1409   *      command is deleted from the table, deleteProc will be called.   *      command is deleted from the table, deleteProc will be called.
1410   *      See the manual entry for details on the calling sequence.   *      See the manual entry for details on the calling sequence.
1411   *   *
1412   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1413   */   */
1414    
1415  Tcl_Command  Tcl_Command
1416  Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)  Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
1417      Tcl_Interp *interp;         /* Token for command interpreter returned by      Tcl_Interp *interp;         /* Token for command interpreter returned by
1418                                   * a previous call to Tcl_CreateInterp. */                                   * a previous call to Tcl_CreateInterp. */
1419      char *cmdName;              /* Name of command. If it contains namespace      char *cmdName;              /* Name of command. If it contains namespace
1420                                   * qualifiers, the new command is put in the                                   * qualifiers, the new command is put in the
1421                                   * specified namespace; otherwise it is put                                   * specified namespace; otherwise it is put
1422                                   * in the global namespace. */                                   * in the global namespace. */
1423      Tcl_CmdProc *proc;          /* Procedure to associate with cmdName. */      Tcl_CmdProc *proc;          /* Procedure to associate with cmdName. */
1424      ClientData clientData;      /* Arbitrary value passed to string proc. */      ClientData clientData;      /* Arbitrary value passed to string proc. */
1425      Tcl_CmdDeleteProc *deleteProc;      Tcl_CmdDeleteProc *deleteProc;
1426                                  /* If not NULL, gives a procedure to call                                  /* If not NULL, gives a procedure to call
1427                                   * when this command is deleted. */                                   * when this command is deleted. */
1428  {  {
1429      Interp *iPtr = (Interp *) interp;      Interp *iPtr = (Interp *) interp;
1430      ImportRef *oldRefPtr = NULL;      ImportRef *oldRefPtr = NULL;
1431      Namespace *nsPtr, *dummy1, *dummy2;      Namespace *nsPtr, *dummy1, *dummy2;
1432      Command *cmdPtr, *refCmdPtr;      Command *cmdPtr, *refCmdPtr;
1433      Tcl_HashEntry *hPtr;      Tcl_HashEntry *hPtr;
1434      char *tail;      char *tail;
1435      int new;      int new;
1436      ImportedCmdData *dataPtr;      ImportedCmdData *dataPtr;
1437    
1438      if (iPtr->flags & DELETED) {      if (iPtr->flags & DELETED) {
1439          /*          /*
1440           * The interpreter is being deleted.  Don't create any new           * The interpreter is being deleted.  Don't create any new
1441           * commands; it's not safe to muck with the interpreter anymore.           * commands; it's not safe to muck with the interpreter anymore.
1442           */           */
1443    
1444          return (Tcl_Command) NULL;          return (Tcl_Command) NULL;
1445      }      }
1446    
1447      /*      /*
1448       * Determine where the command should reside. If its name contains       * Determine where the command should reside. If its name contains
1449       * namespace qualifiers, we put it in the specified namespace;       * namespace qualifiers, we put it in the specified namespace;
1450       * otherwise, we always put it in the global namespace.       * otherwise, we always put it in the global namespace.
1451       */       */
1452    
1453      if (strstr(cmdName, "::") != NULL) {      if (strstr(cmdName, "::") != NULL) {
1454         TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL,         TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL,
1455             CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);             CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
1456         if ((nsPtr == NULL) || (tail == NULL)) {         if ((nsPtr == NULL) || (tail == NULL)) {
1457              return (Tcl_Command) NULL;              return (Tcl_Command) NULL;
1458          }          }
1459      } else {      } else {
1460          nsPtr = iPtr->globalNsPtr;          nsPtr = iPtr->globalNsPtr;
1461          tail = cmdName;          tail = cmdName;
1462      }      }
1463            
1464      hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);      hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
1465      if (!new) {      if (!new) {
1466          /*          /*
1467           * Command already exists. Delete the old one.           * Command already exists. Delete the old one.
1468           * Be careful to preserve any existing import links so we can           * Be careful to preserve any existing import links so we can
1469           * restore them down below.  That way, you can redefine a           * restore them down below.  That way, you can redefine a
1470           * command and its import status will remain intact.           * command and its import status will remain intact.
1471           */           */
1472    
1473          cmdPtr = (Command *) Tcl_GetHashValue(hPtr);          cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
1474          oldRefPtr = cmdPtr->importRefPtr;          oldRefPtr = cmdPtr->importRefPtr;
1475          cmdPtr->importRefPtr = NULL;          cmdPtr->importRefPtr = NULL;
1476    
1477          Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);          Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
1478          hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);          hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
1479          if (!new) {          if (!new) {
1480              /*              /*
1481               * If the deletion callback recreated the command, just throw               * If the deletion callback recreated the command, just throw
1482               * away the new command (if we try to delete it again, we               * away the new command (if we try to delete it again, we
1483               * could get stuck in an infinite loop).               * could get stuck in an infinite loop).
1484               */               */
1485    
1486               ckfree((char*) Tcl_GetHashValue(hPtr));               ckfree((char*) Tcl_GetHashValue(hPtr));
1487          }          }
1488      }      }
1489      cmdPtr = (Command *) ckalloc(sizeof(Command));      cmdPtr = (Command *) ckalloc(sizeof(Command));
1490      Tcl_SetHashValue(hPtr, cmdPtr);      Tcl_SetHashValue(hPtr, cmdPtr);
1491      cmdPtr->hPtr = hPtr;      cmdPtr->hPtr = hPtr;
1492      cmdPtr->nsPtr = nsPtr;      cmdPtr->nsPtr = nsPtr;
1493      cmdPtr->refCount = 1;      cmdPtr->refCount = 1;
1494      cmdPtr->cmdEpoch = 0;      cmdPtr->cmdEpoch = 0;
1495      cmdPtr->compileProc = (CompileProc *) NULL;      cmdPtr->compileProc = (CompileProc *) NULL;
1496      cmdPtr->objProc = TclInvokeStringCommand;      cmdPtr->objProc = TclInvokeStringCommand;
1497      cmdPtr->objClientData = (ClientData) cmdPtr;      cmdPtr->objClientData = (ClientData) cmdPtr;
1498      cmdPtr->proc = proc;      cmdPtr->proc = proc;
1499      cmdPtr->clientData = clientData;      cmdPtr->clientData = clientData;
1500      cmdPtr->deleteProc = deleteProc;      cmdPtr->deleteProc = deleteProc;
1501      cmdPtr->deleteData = clientData;      cmdPtr->deleteData = clientData;
1502      cmdPtr->deleted = 0;      cmdPtr->deleted = 0;
1503      cmdPtr->importRefPtr = NULL;      cmdPtr->importRefPtr = NULL;
1504    
1505      /*      /*
1506       * Plug in any existing import references found above.  Be sure       * Plug in any existing import references found above.  Be sure
1507       * to update all of these references to point to the new command.       * to update all of these references to point to the new command.
1508       */       */
1509    
1510      if (oldRefPtr != NULL) {      if (oldRefPtr != NULL) {
1511          cmdPtr->importRefPtr = oldRefPtr;          cmdPtr->importRefPtr = oldRefPtr;
1512          while (oldRefPtr != NULL) {          while (oldRefPtr != NULL) {
1513              refCmdPtr = oldRefPtr->importedCmdPtr;              refCmdPtr = oldRefPtr->importedCmdPtr;
1514              dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;              dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
1515              dataPtr->realCmdPtr = cmdPtr;              dataPtr->realCmdPtr = cmdPtr;
1516              oldRefPtr = oldRefPtr->nextPtr;              oldRefPtr = oldRefPtr->nextPtr;
1517          }          }
1518      }      }
1519    
1520      /*      /*
1521       * We just created a command, so in its namespace and all of its parent       * We just created a command, so in its namespace and all of its parent
1522       * namespaces, it may shadow global commands with the same name. If any       * namespaces, it may shadow global commands with the same name. If any
1523       * shadowed commands are found, invalidate all cached command references       * shadowed commands are found, invalidate all cached command references
1524       * in the affected namespaces.       * in the affected namespaces.
1525       */       */
1526            
1527      TclResetShadowedCmdRefs(interp, cmdPtr);      TclResetShadowedCmdRefs(interp, cmdPtr);
1528      return (Tcl_Command) cmdPtr;      return (Tcl_Command) cmdPtr;
1529  }  }
1530    
1531  /*  /*
1532   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1533   *   *
1534   * Tcl_CreateObjCommand --   * Tcl_CreateObjCommand --
1535   *   *
1536   *      Define a new object-based command in a command table.   *      Define a new object-based command in a command table.
1537   *   *
1538   * Results:   * Results:
1539   *      The return value is a token for the command, which can   *      The return value is a token for the command, which can
1540   *      be used in future calls to Tcl_GetCommandName.   *      be used in future calls to Tcl_GetCommandName.
1541   *   *
1542   * Side effects:   * Side effects:
1543   *      If no command named "cmdName" already exists for interp, one is   *      If no command named "cmdName" already exists for interp, one is
1544   *      created. Otherwise, if a command does exist, then if the   *      created. Otherwise, if a command does exist, then if the
1545   *      object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume   *      object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume
1546   *      Tcl_CreateCommand was called previously for the same command and   *      Tcl_CreateCommand was called previously for the same command and
1547   *      just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we   *      just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we
1548   *      delete the old command.   *      delete the old command.
1549   *   *
1550   *      In the future, during bytecode evaluation when "cmdName" is seen as   *      In the future, during bytecode evaluation when "cmdName" is seen as
1551   *      the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based   *      the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based
1552   *      Tcl_ObjCmdProc proc will be called. When the command is deleted from   *      Tcl_ObjCmdProc proc will be called. When the command is deleted from
1553   *      the table, deleteProc will be called. See the manual entry for   *      the table, deleteProc will be called. See the manual entry for
1554   *      details on the calling sequence.   *      details on the calling sequence.
1555   *   *
1556   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1557   */   */
1558    
1559  Tcl_Command  Tcl_Command
1560  Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)  Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
1561      Tcl_Interp *interp;         /* Token for command interpreter (returned      Tcl_Interp *interp;         /* Token for command interpreter (returned
1562                                   * by previous call to Tcl_CreateInterp). */                                   * by previous call to Tcl_CreateInterp). */
1563      char *cmdName;              /* Name of command. If it contains namespace      char *cmdName;              /* Name of command. If it contains namespace
1564                                   * qualifiers, the new command is put in the                                   * qualifiers, the new command is put in the
1565                                   * specified namespace; otherwise it is put                                   * specified namespace; otherwise it is put
1566                                   * in the global namespace. */                                   * in the global namespace. */
1567      Tcl_ObjCmdProc *proc;       /* Object-based procedure to associate with      Tcl_ObjCmdProc *proc;       /* Object-based procedure to associate with
1568                                   * name. */                                   * name. */
1569      ClientData clientData;      /* Arbitrary value to pass to object      ClientData clientData;      /* Arbitrary value to pass to object
1570                                   * procedure. */                                   * procedure. */
1571      Tcl_CmdDeleteProc *deleteProc;      Tcl_CmdDeleteProc *deleteProc;
1572                                  /* If not NULL, gives a procedure to call                                  /* If not NULL, gives a procedure to call
1573                                   * when this command is deleted. */                                   * when this command is deleted. */
1574  {  {
1575      Interp *iPtr = (Interp *) interp;      Interp *iPtr = (Interp *) interp;
1576      ImportRef *oldRefPtr = NULL;      ImportRef *oldRefPtr = NULL;
1577      Namespace *nsPtr, *dummy1, *dummy2;      Namespace *nsPtr, *dummy1, *dummy2;
1578      Command *cmdPtr, *refCmdPtr;      Command *cmdPtr, *refCmdPtr;
1579      Tcl_HashEntry *hPtr;      Tcl_HashEntry *hPtr;
1580      char *tail;      char *tail;
1581      int new;      int new;
1582      ImportedCmdData *dataPtr;      ImportedCmdData *dataPtr;
1583    
1584      if (iPtr->flags & DELETED) {      if (iPtr->flags & DELETED) {
1585          /*          /*
1586           * The interpreter is being deleted.  Don't create any new           * The interpreter is being deleted.  Don't create any new
1587           * commands;  it's not safe to muck with the interpreter anymore.           * commands;  it's not safe to muck with the interpreter anymore.
1588           */           */
1589    
1590          return (Tcl_Command) NULL;          return (Tcl_Command) NULL;
1591      }      }
1592    
1593      /*      /*
1594       * Determine where the command should reside. If its name contains       * Determine where the command should reside. If its name contains
1595       * namespace qualifiers, we put it in the specified namespace;       * namespace qualifiers, we put it in the specified namespace;
1596       * otherwise, we always put it in the global namespace.       * otherwise, we always put it in the global namespace.
1597       */       */
1598    
1599      if (strstr(cmdName, "::") != NULL) {      if (strstr(cmdName, "::") != NULL) {
1600         TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL,         TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL,
1601             CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);             CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
1602         if ((nsPtr == NULL) || (tail == NULL)) {         if ((nsPtr == NULL) || (tail == NULL)) {
1603              return (Tcl_Command) NULL;              return (Tcl_Command) NULL;
1604          }          }
1605      } else {      } else {
1606          nsPtr = iPtr->globalNsPtr;          nsPtr = iPtr->globalNsPtr;
1607          tail = cmdName;          tail = cmdName;
1608      }      }
1609    
1610      hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);      hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
1611      if (!new) {      if (!new) {
1612          cmdPtr = (Command *) Tcl_GetHashValue(hPtr);          cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
1613    
1614          /*          /*
1615           * Command already exists. If its object-based Tcl_ObjCmdProc is           * Command already exists. If its object-based Tcl_ObjCmdProc is
1616           * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the           * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the
1617           * argument "proc". Otherwise, we delete the old command.           * argument "proc". Otherwise, we delete the old command.
1618           */           */
1619    
1620          if (cmdPtr->objProc == TclInvokeStringCommand) {          if (cmdPtr->objProc == TclInvokeStringCommand) {
1621              cmdPtr->objProc = proc;              cmdPtr->objProc = proc;
1622              cmdPtr->objClientData = clientData;              cmdPtr->objClientData = clientData;
1623              cmdPtr->deleteProc = deleteProc;              cmdPtr->deleteProc = deleteProc;
1624              cmdPtr->deleteData = clientData;              cmdPtr->deleteData = clientData;
1625              return (Tcl_Command) cmdPtr;              return (Tcl_Command) cmdPtr;
1626          }          }
1627    
1628          /*          /*
1629           * Otherwise, we delete the old command.  Be careful to preserve           * Otherwise, we delete the old command.  Be careful to preserve
1630           * any existing import links so we can restore them down below.           * any existing import links so we can restore them down below.
1631           * That way, you can redefine a command and its import status           * That way, you can redefine a command and its import status
1632           * will remain intact.           * will remain intact.
1633           */           */
1634    
1635          oldRefPtr = cmdPtr->importRefPtr;          oldRefPtr = cmdPtr->importRefPtr;
1636          cmdPtr->importRefPtr = NULL;          cmdPtr->importRefPtr = NULL;
1637    
1638          Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);          Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
1639          hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);          hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
1640          if (!new) {          if (!new) {
1641              /*              /*
1642               * If the deletion callback recreated the command, just throw               * If the deletion callback recreated the command, just throw
1643               * away the new command (if we try to delete it again, we               * away the new command (if we try to delete it again, we
1644               * could get stuck in an infinite loop).               * could get stuck in an infinite loop).
1645               */               */
1646    
1647               ckfree((char *) Tcl_GetHashValue(hPtr));               ckfree((char *) Tcl_GetHashValue(hPtr));
1648          }          }
1649      }      }
1650      cmdPtr = (Command *) ckalloc(sizeof(Command));      cmdPtr = (Command *) ckalloc(sizeof(Command));
1651      Tcl_SetHashValue(hPtr, cmdPtr);      Tcl_SetHashValue(hPtr, cmdPtr);
1652      cmdPtr->hPtr = hPtr;      cmdPtr->hPtr = hPtr;
1653      cmdPtr->nsPtr = nsPtr;      cmdPtr->nsPtr = nsPtr;
1654      cmdPtr->refCount = 1;      cmdPtr->refCount = 1;
1655      cmdPtr->cmdEpoch = 0;      cmdPtr->cmdEpoch = 0;
1656      cmdPtr->compileProc = (CompileProc *) NULL;      cmdPtr->compileProc = (CompileProc *) NULL;
1657      cmdPtr->objProc = proc;      cmdPtr->objProc = proc;
1658      cmdPtr->objClientData = clientData;      cmdPtr->objClientData = clientData;
1659      cmdPtr->proc = TclInvokeObjectCommand;      cmdPtr->proc = TclInvokeObjectCommand;
1660      cmdPtr->clientData = (ClientData) cmdPtr;      cmdPtr->clientData = (ClientData) cmdPtr;
1661      cmdPtr->deleteProc = deleteProc;      cmdPtr->deleteProc = deleteProc;
1662      cmdPtr->deleteData = clientData;      cmdPtr->deleteData = clientData;
1663      cmdPtr->deleted = 0;      cmdPtr->deleted = 0;
1664      cmdPtr->importRefPtr = NULL;      cmdPtr->importRefPtr = NULL;
1665    
1666      /*      /*
1667       * Plug in any existing import references found above.  Be sure       * Plug in any existing import references found above.  Be sure
1668       * to update all of these references to point to the new command.       * to update all of these references to point to the new command.
1669       */       */
1670    
1671      if (oldRefPtr != NULL) {      if (oldRefPtr != NULL) {
1672          cmdPtr->importRefPtr = oldRefPtr;          cmdPtr->importRefPtr = oldRefPtr;
1673          while (oldRefPtr != NULL) {          while (oldRefPtr != NULL) {
1674              refCmdPtr = oldRefPtr->importedCmdPtr;              refCmdPtr = oldRefPtr->importedCmdPtr;
1675              dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;              dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
1676              dataPtr->realCmdPtr = cmdPtr;              dataPtr->realCmdPtr = cmdPtr;
1677              oldRefPtr = oldRefPtr->nextPtr;              oldRefPtr = oldRefPtr->nextPtr;
1678          }          }
1679      }      }
1680            
1681      /*      /*
1682       * We just created a command, so in its namespace and all of its parent       * We just created a command, so in its namespace and all of its parent
1683       * namespaces, it may shadow global commands with the same name. If any       * namespaces, it may shadow global commands with the same name. If any
1684       * shadowed commands are found, invalidate all cached command references       * shadowed commands are found, invalidate all cached command references
1685       * in the affected namespaces.       * in the affected namespaces.
1686       */       */
1687            
1688      TclResetShadowedCmdRefs(interp, cmdPtr);      TclResetShadowedCmdRefs(interp, cmdPtr);
1689      return (Tcl_Command) cmdPtr;      return (Tcl_Command) cmdPtr;
1690  }  }
1691    
1692  /*  /*
1693   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1694   *   *
1695   * TclInvokeStringCommand --   * TclInvokeStringCommand --
1696   *   *
1697   *      "Wrapper" Tcl_ObjCmdProc used to call an existing string-based   *      "Wrapper" Tcl_ObjCmdProc used to call an existing string-based
1698   *      Tcl_CmdProc if no object-based procedure exists for a command. A   *      Tcl_CmdProc if no object-based procedure exists for a command. A
1699   *      pointer to this procedure is stored as the Tcl_ObjCmdProc in a   *      pointer to this procedure is stored as the Tcl_ObjCmdProc in a
1700   *      Command structure. It simply turns around and calls the string   *      Command structure. It simply turns around and calls the string
1701   *      Tcl_CmdProc in the Command structure.   *      Tcl_CmdProc in the Command structure.
1702   *   *
1703   * Results:   * Results:
1704   *      A standard Tcl object result value.   *      A standard Tcl object result value.
1705   *   *
1706   * Side effects:   * Side effects:
1707   *      Besides those side effects of the called Tcl_CmdProc,   *      Besides those side effects of the called Tcl_CmdProc,
1708   *      TclInvokeStringCommand allocates and frees storage.   *      TclInvokeStringCommand allocates and frees storage.
1709   *   *
1710   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1711   */   */
1712    
1713  int  int
1714  TclInvokeStringCommand(clientData, interp, objc, objv)  TclInvokeStringCommand(clientData, interp, objc, objv)
1715      ClientData clientData;      /* Points to command's Command structure. */      ClientData clientData;      /* Points to command's Command structure. */
1716      Tcl_Interp *interp;         /* Current interpreter. */      Tcl_Interp *interp;         /* Current interpreter. */
1717      register int objc;          /* Number of arguments. */      register int objc;          /* Number of arguments. */
1718      Tcl_Obj *CONST objv[];      /* Argument objects. */      Tcl_Obj *CONST objv[];      /* Argument objects. */
1719  {  {
1720      register Command *cmdPtr = (Command *) clientData;      register Command *cmdPtr = (Command *) clientData;
1721      register int i;      register int i;
1722      int result;      int result;
1723    
1724      /*      /*
1725       * This procedure generates an argv array for the string arguments. It       * This procedure generates an argv array for the string arguments. It
1726       * starts out with stack-allocated space but uses dynamically-allocated       * starts out with stack-allocated space but uses dynamically-allocated
1727       * storage if needed.       * storage if needed.
1728       */       */
1729    
1730  #define NUM_ARGS 20  #define NUM_ARGS 20
1731      char *(argStorage[NUM_ARGS]);      char *(argStorage[NUM_ARGS]);
1732      char **argv = argStorage;      char **argv = argStorage;
1733    
1734      /*      /*
1735       * Create the string argument array "argv". Make sure argv is large       * Create the string argument array "argv". Make sure argv is large
1736       * enough to hold the objc arguments plus 1 extra for the zero       * enough to hold the objc arguments plus 1 extra for the zero
1737       * end-of-argv word.       * end-of-argv word.
1738       */       */
1739    
1740      if ((objc + 1) > NUM_ARGS) {      if ((objc + 1) > NUM_ARGS) {
1741          argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));          argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
1742      }      }
1743    
1744      for (i = 0;  i < objc;  i++) {      for (i = 0;  i < objc;  i++) {
1745          argv[i] = Tcl_GetString(objv[i]);          argv[i] = Tcl_GetString(objv[i]);
1746      }      }
1747      argv[objc] = 0;      argv[objc] = 0;
1748    
1749      /*      /*
1750       * Invoke the command's string-based Tcl_CmdProc.       * Invoke the command's string-based Tcl_CmdProc.
1751       */       */
1752    
1753      result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv);      result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv);
1754    
1755      /*      /*
1756       * Free the argv array if malloc'ed storage was used.       * Free the argv array if malloc'ed storage was used.
1757       */       */
1758    
1759      if (argv != argStorage) {      if (argv != argStorage) {
1760          ckfree((char *) argv);          ckfree((char *) argv);
1761      }      }
1762      return result;      return result;
1763  #undef NUM_ARGS  #undef NUM_ARGS
1764  }  }
1765    
1766  /*  /*
1767   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1768   *   *
1769   * TclInvokeObjectCommand --   * TclInvokeObjectCommand --
1770   *   *
1771   *      "Wrapper" Tcl_CmdProc used to call an existing object-based   *      "Wrapper" Tcl_CmdProc used to call an existing object-based
1772   *      Tcl_ObjCmdProc if no string-based procedure exists for a command.   *      Tcl_ObjCmdProc if no string-based procedure exists for a command.
1773   *      A pointer to this procedure is stored as the Tcl_CmdProc in a   *      A pointer to this procedure is stored as the Tcl_CmdProc in a
1774   *      Command structure. It simply turns around and calls the object   *      Command structure. It simply turns around and calls the object
1775   *      Tcl_ObjCmdProc in the Command structure.   *      Tcl_ObjCmdProc in the Command structure.
1776   *   *
1777   * Results:   * Results:
1778   *      A standard Tcl string result value.   *      A standard Tcl string result value.
1779   *   *
1780   * Side effects:   * Side effects:
1781   *      Besides those side effects of the called Tcl_CmdProc,   *      Besides those side effects of the called Tcl_CmdProc,
1782   *      TclInvokeStringCommand allocates and frees storage.   *      TclInvokeStringCommand allocates and frees storage.
1783   *   *
1784   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1785   */   */
1786    
1787  int  int
1788  TclInvokeObjectCommand(clientData, interp, argc, argv)  TclInvokeObjectCommand(clientData, interp, argc, argv)
1789      ClientData clientData;      /* Points to command's Command structure. */      ClientData clientData;      /* Points to command's Command structure. */
1790      Tcl_Interp *interp;         /* Current interpreter. */      Tcl_Interp *interp;         /* Current interpreter. */
1791      int argc;                   /* Number of arguments. */      int argc;                   /* Number of arguments. */
1792      register char **argv;       /* Argument strings. */      register char **argv;       /* Argument strings. */
1793  {  {
1794      Command *cmdPtr = (Command *) clientData;      Command *cmdPtr = (Command *) clientData;
1795      register Tcl_Obj *objPtr;      register Tcl_Obj *objPtr;
1796      register int i;      register int i;
1797      int length, result;      int length, result;
1798    
1799      /*      /*
1800       * This procedure generates an objv array for object arguments that hold       * This procedure generates an objv array for object arguments that hold
1801       * the argv strings. It starts out with stack-allocated space but uses       * the argv strings. It starts out with stack-allocated space but uses
1802       * dynamically-allocated storage if needed.       * dynamically-allocated storage if needed.
1803       */       */
1804    
1805  #define NUM_ARGS 20  #define NUM_ARGS 20
1806      Tcl_Obj *(argStorage[NUM_ARGS]);      Tcl_Obj *(argStorage[NUM_ARGS]);
1807      register Tcl_Obj **objv = argStorage;      register Tcl_Obj **objv = argStorage;
1808    
1809      /*      /*
1810       * Create the object argument array "objv". Make sure objv is large       * Create the object argument array "objv". Make sure objv is large
1811       * enough to hold the objc arguments plus 1 extra for the zero       * enough to hold the objc arguments plus 1 extra for the zero
1812       * end-of-objv word.       * end-of-objv word.
1813       */       */
1814    
1815      if ((argc + 1) > NUM_ARGS) {      if ((argc + 1) > NUM_ARGS) {
1816          objv = (Tcl_Obj **)          objv = (Tcl_Obj **)
1817              ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));              ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
1818      }      }
1819    
1820      for (i = 0;  i < argc;  i++) {      for (i = 0;  i < argc;  i++) {
1821          length = strlen(argv[i]);          length = strlen(argv[i]);
1822          TclNewObj(objPtr);          TclNewObj(objPtr);
1823          TclInitStringRep(objPtr, argv[i], length);          TclInitStringRep(objPtr, argv[i], length);
1824          Tcl_IncrRefCount(objPtr);          Tcl_IncrRefCount(objPtr);
1825          objv[i] = objPtr;          objv[i] = objPtr;
1826      }      }
1827      objv[argc] = 0;      objv[argc] = 0;
1828    
1829      /*      /*
1830       * Invoke the command's object-based Tcl_ObjCmdProc.       * Invoke the command's object-based Tcl_ObjCmdProc.
1831       */       */
1832    
1833      result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv);      result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv);
1834    
1835      /*      /*
1836       * Move the interpreter's object result to the string result,       * Move the interpreter's object result to the string result,
1837       * then reset the object result.       * then reset the object result.
1838       */       */
1839    
1840      Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),      Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
1841              TCL_VOLATILE);              TCL_VOLATILE);
1842            
1843      /*      /*
1844       * Decrement the ref counts for the argument objects created above,       * Decrement the ref counts for the argument objects created above,
1845       * then free the objv array if malloc'ed storage was used.       * then free the objv array if malloc'ed storage was used.
1846       */       */
1847    
1848      for (i = 0;  i < argc;  i++) {      for (i = 0;  i < argc;  i++) {
1849          objPtr = objv[i];          objPtr = objv[i];
1850          Tcl_DecrRefCount(objPtr);          Tcl_DecrRefCount(objPtr);
1851      }      }
1852      if (objv != argStorage) {      if (objv != argStorage) {
1853          ckfree((char *) objv);          ckfree((char *) objv);
1854      }      }
1855      return result;      return result;
1856  #undef NUM_ARGS  #undef NUM_ARGS
1857  }  }
1858    
1859  /*  /*
1860   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1861   *   *
1862   * TclRenameCommand --   * TclRenameCommand --
1863   *   *
1864   *      Called to give an existing Tcl command a different name. Both the   *      Called to give an existing Tcl command a different name. Both the
1865   *      old command name and the new command name can have "::" namespace   *      old command name and the new command name can have "::" namespace
1866   *      qualifiers. If the new command has a different namespace context,   *      qualifiers. If the new command has a different namespace context,
1867   *      the command will be moved to that namespace and will execute in   *      the command will be moved to that namespace and will execute in
1868   *      the context of that new namespace.   *      the context of that new namespace.
1869   *   *
1870   *      If the new command name is NULL or the null string, the command is   *      If the new command name is NULL or the null string, the command is
1871   *      deleted.   *      deleted.
1872   *   *
1873   * Results:   * Results:
1874   *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.   *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
1875   *   *
1876   * Side effects:   * Side effects:
1877   *      If anything goes wrong, an error message is returned in the   *      If anything goes wrong, an error message is returned in the
1878   *      interpreter's result object.   *      interpreter's result object.
1879   *   *
1880   *----------------------------------------------------------------------   *----------------------------------------------------------------------
1881   */   */
1882    
1883  int  int
1884  TclRenameCommand(interp, oldName, newName)  TclRenameCommand(interp, oldName, newName)
1885      Tcl_Interp *interp;                 /* Current interpreter. */      Tcl_Interp *interp;                 /* Current interpreter. */
1886      char *oldName;                      /* Existing command name. */      char *oldName;                      /* Existing command name. */
1887      char *newName;                      /* New command name. */      char *newName;                      /* New command name. */
1888  {  {
1889      Interp *iPtr = (Interp *) interp;      Interp *iPtr = (Interp *) interp;
1890      char *newTail;      char *newTail;
1891      Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2;      Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2;
1892      Tcl_Command cmd;      Tcl_Command cmd;
1893      Command *cmdPtr;      Command *cmdPtr;
1894      Tcl_HashEntry *hPtr, *oldHPtr;      Tcl_HashEntry *hPtr, *oldHPtr;
1895      int new, result;      int new, result;
1896    
1897      /*      /*
1898       * Find the existing command. An error is returned if cmdName can't       * Find the existing command. An error is returned if cmdName can't
1899       * be found.       * be found.
1900       */       */
1901    
1902      cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL,      cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL,
1903          /*flags*/ 0);          /*flags*/ 0);
1904      cmdPtr = (Command *) cmd;      cmdPtr = (Command *) cmd;
1905      if (cmdPtr == NULL) {      if (cmdPtr == NULL) {
1906          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ",          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ",
1907                  ((newName == NULL)||(*newName == '\0'))? "delete":"rename",                  ((newName == NULL)||(*newName == '\0'))? "delete":"rename",
1908                  " \"", oldName, "\": command doesn't exist", (char *) NULL);                  " \"", oldName, "\": command doesn't exist", (char *) NULL);
1909          return TCL_ERROR;          return TCL_ERROR;
1910      }      }
1911      cmdNsPtr = cmdPtr->nsPtr;      cmdNsPtr = cmdPtr->nsPtr;
1912    
1913      /*      /*
1914       * If the new command name is NULL or empty, delete the command. Do this       * If the new command name is NULL or empty, delete the command. Do this
1915       * with Tcl_DeleteCommandFromToken, since we already have the command.       * with Tcl_DeleteCommandFromToken, since we already have the command.
1916       */       */
1917            
1918      if ((newName == NULL) || (*newName == '\0')) {      if ((newName == NULL) || (*newName == '\0')) {
1919          Tcl_DeleteCommandFromToken(interp, cmd);          Tcl_DeleteCommandFromToken(interp, cmd);
1920          return TCL_OK;          return TCL_OK;
1921      }      }
1922    
1923      /*      /*
1924       * Make sure that the destination command does not already exist.       * Make sure that the destination command does not already exist.
1925       * The rename operation is like creating a command, so we should       * The rename operation is like creating a command, so we should
1926       * automatically create the containing namespaces just like       * automatically create the containing namespaces just like
1927       * Tcl_CreateCommand would.       * Tcl_CreateCommand would.
1928       */       */
1929    
1930      TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL,      TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL,
1931         CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail);         CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail);
1932    
1933      if ((newNsPtr == NULL) || (newTail == NULL)) {      if ((newNsPtr == NULL) || (newTail == NULL)) {
1934          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1935                   "can't rename to \"", newName, "\": bad command name",                   "can't rename to \"", newName, "\": bad command name",
1936                   (char *) NULL);                   (char *) NULL);
1937          return TCL_ERROR;          return TCL_ERROR;
1938      }      }
1939      if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {      if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
1940          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1941                   "can't rename to \"", newName,                   "can't rename to \"", newName,
1942                   "\": command already exists", (char *) NULL);                   "\": command already exists", (char *) NULL);
1943          return TCL_ERROR;          return TCL_ERROR;
1944      }      }
1945    
1946    
1947      /*      /*
1948       * Warning: any changes done in the code here are likely       * Warning: any changes done in the code here are likely
1949       * to be needed in Tcl_HideCommand() code too.       * to be needed in Tcl_HideCommand() code too.
1950       * (until the common parts are extracted out)     --dl       * (until the common parts are extracted out)     --dl
1951       */       */
1952    
1953      /*      /*
1954       * Put the command in the new namespace so we can check for an alias       * Put the command in the new namespace so we can check for an alias
1955       * loop. Since we are adding a new command to a namespace, we must       * loop. Since we are adding a new command to a namespace, we must
1956       * handle any shadowing of the global commands that this might create.       * handle any shadowing of the global commands that this might create.
1957       */       */
1958            
1959      oldHPtr = cmdPtr->hPtr;      oldHPtr = cmdPtr->hPtr;
1960      hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new);      hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new);
1961      Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);      Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
1962      cmdPtr->hPtr = hPtr;      cmdPtr->hPtr = hPtr;
1963      cmdPtr->nsPtr = newNsPtr;      cmdPtr->nsPtr = newNsPtr;
1964      TclResetShadowedCmdRefs(interp, cmdPtr);      TclResetShadowedCmdRefs(interp, cmdPtr);
1965    
1966      /*      /*
1967       * Now check for an alias loop. If we detect one, put everything back       * Now check for an alias loop. If we detect one, put everything back
1968       * the way it was and report the error.       * the way it was and report the error.
1969       */       */
1970    
1971      result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr);      result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr);
1972      if (result != TCL_OK) {      if (result != TCL_OK) {
1973          Tcl_DeleteHashEntry(cmdPtr->hPtr);          Tcl_DeleteHashEntry(cmdPtr->hPtr);
1974          cmdPtr->hPtr = oldHPtr;          cmdPtr->hPtr = oldHPtr;
1975          cmdPtr->nsPtr = cmdNsPtr;          cmdPtr->nsPtr = cmdNsPtr;
1976          return result;          return result;
1977      }      }
1978    
1979      /*      /*
1980       * The new command name is okay, so remove the command from its       * The new command name is okay, so remove the command from its
1981       * current namespace. This is like deleting the command, so bump       * current namespace. This is like deleting the command, so bump
1982       * the cmdEpoch to invalidate any cached references to the command.       * the cmdEpoch to invalidate any cached references to the command.
1983       */       */
1984            
1985      Tcl_DeleteHashEntry(oldHPtr);      Tcl_DeleteHashEntry(oldHPtr);
1986      cmdPtr->cmdEpoch++;      cmdPtr->cmdEpoch++;
1987    
1988      /*      /*
1989       * If the command being renamed has a compile procedure, increment the       * If the command being renamed has a compile procedure, increment the
1990       * interpreter's compileEpoch to invalidate its compiled code. This       * interpreter's compileEpoch to invalidate its compiled code. This
1991       * makes sure that we don't later try to execute old code compiled for       * makes sure that we don't later try to execute old code compiled for
1992       * the now-renamed command.       * the now-renamed command.
1993       */       */
1994    
1995      if (cmdPtr->compileProc != NULL) {      if (cmdPtr->compileProc != NULL) {
1996          iPtr->compileEpoch++;          iPtr->compileEpoch++;
1997      }      }
1998    
1999      return TCL_OK;      return TCL_OK;
2000  }  }
2001    
2002  /*  /*
2003   *----------------------------------------------------------------------   *----------------------------------------------------------------------
2004   *   *
2005   * Tcl_SetCommandInfo --   * Tcl_SetCommandInfo --
2006   *   *
2007   *      Modifies various information about a Tcl command. Note that   *      Modifies various information about a Tcl command. Note that
2008   *      this procedure will not change a command's namespace; use   *      this procedure will not change a command's namespace; use
2009   *      Tcl_RenameCommand to do that. Also, the isNativeObjectProc   *      Tcl_RenameCommand to do that. Also, the isNativeObjectProc
2010   *      member of *infoPtr is ignored.   *      member of *infoPtr is ignored.
2011   *   *
2012   * Results:   * Results:
2013   *      If cmdName exists in interp, then the information at *infoPtr   *      If cmdName exists in interp, then the information at *infoPtr
2014   *      is stored with the command in place of the current information   *      is stored with the command in place of the current information
2015   *      and 1 is returned. If the command doesn't exist then 0 is   *      and 1 is returned. If the command doesn't exist then 0 is
2016   *      returned.   *      returned.
2017   *   *
2018   * Side effects:   * Side effects:
2019   *      None.   *      None.
2020   *   *
2021   *----------------------------------------------------------------------   *----------------------------------------------------------------------
2022   */   */
2023    
2024  int  int
2025  Tcl_SetCommandInfo(interp, cmdName, infoPtr)  Tcl_SetCommandInfo(interp, cmdName, infoPtr)
2026      Tcl_Interp *interp;                 /* Interpreter in which to look      Tcl_Interp *interp;                 /* Interpreter in which to look
2027                                           * for command. */                                           * for command. */
2028      char *cmdName;                      /* Name of desired command. */      char *cmdName;                      /* Name of desired command. */
2029      Tcl_CmdInfo *infoPtr;               /* Where to find information      Tcl_CmdInfo *infoPtr;               /* Where to find information
2030                                           * to store in the command. */                                           * to store in the command. */
2031  {  {
2032      Tcl_Command cmd;      Tcl_Command cmd;
2033      Command *cmdPtr;      Command *cmdPtr;
2034    
2035      cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,      cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
2036              /*flags*/ 0);              /*flags*/ 0);
2037      if (cmd == (Tcl_Command) NULL) {      if (cmd == (Tcl_Command) NULL) {
2038          return 0;          return 0;
2039      }      }
2040    
2041      /*      /*
2042       * The isNativeObjectProc and nsPtr members of *infoPtr are ignored.       * The isNativeObjectProc and nsPtr members of *infoPtr are ignored.
2043       */       */
2044            
2045      cmdPtr = (Command *) cmd;      cmdPtr = (Command *) cmd;
2046      cmdPtr->proc = infoPtr->proc;      cmdPtr->proc = infoPtr->proc;
2047      cmdPtr->clientData = infoPtr->clientData;      cmdPtr->clientData = infoPtr->clientData;
2048      if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {      if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
2049          cmdPtr->objProc = TclInvokeStringCommand;          cmdPtr->objProc = TclInvokeStringCommand;
2050          cmdPtr->objClientData = (ClientData) cmdPtr;          cmdPtr->objClientData = (ClientData) cmdPtr;
2051      } else {      } else {
2052          cmdPtr->objProc = infoPtr->objProc;          cmdPtr->objProc = infoPtr->objProc;
2053          cmdPtr->objClientData = infoPtr->objClientData;          cmdPtr->objClientData = infoPtr->objClientData;
2054      }      }
2055      cmdPtr->deleteProc = infoPtr->deleteProc;      cmdPtr->deleteProc = infoPtr->deleteProc;
2056      cmdPtr->deleteData = infoPtr->deleteData;      cmdPtr->deleteData = infoPtr->deleteData;
2057      return 1;      return 1;
2058  }  }
2059    
2060  /*  /*
2061   *----------------------------------------------------------------------   *----------------------------------------------------------------------
2062   *   *
2063   * Tcl_GetCommandInfo --   * Tcl_GetCommandInfo --
2064   *   *
2065   *      Returns various information about a Tcl command.   *      Returns various information about a Tcl command.
2066   *   *
2067   * Results:   * Results:
2068   *      If cmdName exists in interp, then *infoPtr is modified to   *      If cmdName exists in interp, then *infoPtr is modified to
2069   *      hold information about cmdName and 1 is returned.  If the   *      hold information about cmdName and 1 is returned.  If the
2070   *      command doesn't exist then 0 is returned and *infoPtr isn't   *      command doesn't exist then 0 is returned and *infoPtr isn't
2071   *      modified.   *      modified.
2072   *   *
2073   * Side effects:   * Side effects:
2074   *      None.   *      None.
2075   *   *
2076   *----------------------------------------------------------------------   *----------------------------------------------------------------------
2077   */   */
2078    
2079  int  int
2080  Tcl_GetCommandInfo(interp, cmdName, infoPtr)  Tcl_GetCommandInfo(interp, cmdName, infoPtr)
2081      Tcl_Interp *interp;                 /* Interpreter in which to look      Tcl_Interp *interp;                 /* Interpreter in which to look
2082                                           * for command. */                                           * for command. */
2083      char *cmdName;                      /* Name of desired command. */      char *cmdName;                      /* Name of desired command. */
2084      Tcl_CmdInfo *infoPtr;               /* Where to store information about      Tcl_CmdInfo *infoPtr;               /* Where to store information about
2085                                           * command. */                                           * command. */
2086  {  {
2087      Tcl_Command cmd;      Tcl_Command cmd;
2088      Command *cmdPtr;      Command *cmdPtr;
2089    
2090      cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,      cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
2091              /*flags*/ 0);              /*flags*/ 0);
2092      if (cmd == (Tcl_Command) NULL) {      if (cmd == (Tcl_Command) NULL) {
2093          return 0;          return 0;
2094      }      }
2095    
2096      /*      /*
2097       * Set isNativeObjectProc 1 if objProc was registered by a call to       * Set isNativeObjectProc 1 if objProc was registered by a call to
2098       * Tcl_CreateObjCommand. Otherwise set it to 0.       * Tcl_CreateObjCommand. Otherwise set it to 0.
2099       */       */
2100    
2101      cmdPtr = (Command *) cmd;      cmdPtr = (Command *) cmd;
2102      infoPtr->isNativeObjectProc =      infoPtr->isNativeObjectProc =
2103              (cmdPtr->objProc != TclInvokeStringCommand);              (cmdPtr->objProc != TclInvokeStringCommand);
2104      infoPtr->objProc = cmdPtr->objProc;      infoPtr->objProc = cmdPtr->objProc;
2105      infoPtr->objClientData = cmdPtr->objClientData;      infoPtr->objClientData = cmdPtr->objClientData;
2106      infoPtr->proc = cmdPtr->proc;      infoPtr->proc = cmdPtr->proc;
2107      infoPtr->clientData = cmdPtr->clientData;      infoPtr->clientData = cmdPtr->clientData;
2108      infoPtr->deleteProc = cmdPtr->deleteProc;      infoPtr->deleteProc = cmdPtr->deleteProc;
2109      infoPtr->deleteData = cmdPtr->deleteData;      infoPtr->deleteData = cmdPtr->deleteData;
2110      infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;      infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
2111      return 1;      return 1;
2112  }  }
2113    
2114  /*  /*
2115   *----------------------------------------------------------------------   *----------------------------------------------------------------------
2116   *   *
2117   * Tcl_GetCommandName --   * Tcl_GetCommandName --
2118   *   *
2119   *      Given a token returned by Tcl_CreateCommand, this procedure   *      Given a token returned by Tcl_CreateCommand, this procedure
2120   *      returns the current name of the command (which may have changed   *      returns the current name of the command (which may have changed
2121   *      due to renaming).   *      due to renaming).
2122   *   *
2123   * Results:   * Results:
2124   *      The return value is the name of the given command.   *      The return value is the name of the given command.
2125   *   *
2126   * Side effects:   * Side effects:
2127   *      None.   *      None.
2128   *   *
2129   *----------------------------------------------------------------------   *----------------------------------------------------------------------
2130   */   */
2131    
2132  char *  char *
2133  Tcl_GetCommandName(interp, command)  Tcl_GetCommandName(interp, command)
2134      Tcl_Interp *interp;         /* Interpreter containing the command. */      Tcl_Interp *interp;         /* Interpreter containing the command. */
2135      Tcl_Command command;        /* Token for command returned by a previous      Tcl_Command command;        /* Token for command returned by a previous
2136                                   * call to Tcl_CreateCommand. The command                                   * call to Tcl_CreateCommand. The command
2137                                   * must not have been deleted. */                                   * must not have been deleted. */
2138  {  {
2139      Command *cmdPtr = (Command *) command;      Command *cmdPtr = (Command *) command;
2140    
2141      if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) {      if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) {
2142    
2143          /*          /*
2144           * This should only happen if command was "created" after the           * This should only happen if command was "created" after the
2145           * interpreter began to be deleted, so there isn't really any           * interpreter began to be deleted, so there isn't really any
2146           * command. Just return an empty string.           * command. Just return an empty string.
2147           */           */
2148    
2149          return "";          return "";
2150      }      }
2151      return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);      return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
2152  }  }
2153    
2154  /*  /*
2155   *----------------------------------------------------------------------   *----------------------------------------------------------------------
2156   *   *
2157   * Tcl_GetCommandFullName --   * Tcl_GetCommandFullName --
2158   *   *
2159   *      Given a token returned by, e.g., Tcl_CreateCommand or   *      Given a token returned by, e.g., Tcl_CreateCommand or
2160   *      Tcl_FindCommand, this procedure appends to an object the command's   *      Tcl_FindCommand, this procedure appends to an object the command's
2161   *      full name, qualified by a sequence of parent namespace names. The   *      full name, qualified by a sequence of parent namespace names. The
2162   *      command's fully-qualified name may have changed due to renaming.   *      command's fully-qualified name may have changed due to renaming.
2163   *   *
2164   * Results:   * Results:
2165   *      None.   *      None.
2166   *   *
2167   * Side effects:   * Side effects:
2168   *      The command's fully-qualified name is appended to the string   *      The command's fully-qualified name is appended to the string
2169   *      representation of objPtr.   *      representation of objPtr.
2170   *   *
2171   *----------------------------------------------------------------------   *----------------------------------------------------------------------
2172   */   */
2173    
2174  void  void
2175  Tcl_GetCommandFullName(interp, command, objPtr)  Tcl_GetCommandFullName(interp, command, objPtr)
2176      Tcl_Interp *interp;         /* Interpreter containing the command. */      Tcl_Interp *interp;         /* Interpreter containing the command. */
2177      Tcl_Command command;        /* Token for command returned by a previous      Tcl_Command command;        /* Token for command returned by a previous
2178                                   * call to Tcl_CreateCommand. The command                                   * call to Tcl_CreateCommand. The command
2179                                   * must not have been deleted. */                                   * must not have been deleted. */
2180      Tcl_Obj *objPtr;            /* Points to the object onto which the      Tcl_Obj *objPtr;            /* Points to the object onto which the
2181                                   * command's full name is appended. */                                   * command's full name is appended. */
2182    
2183  {  {
2184      Interp *iPtr = (Interp *) interp;      Interp *iPtr = (Interp *) interp;
2185      register Command *cmdPtr = (Command *) command;      register Command *cmdPtr = (Command *) command;
2186      char *name;      char *name;
2187    
2188      /*      /*
2189       * Add the full name of the containing namespace, followed by the "::"       * Add the full name of the containing namespace, followed by the "::"
2190       * separator, and the command name.       * separator, and the command name.
2191       */       */
2192    
2193      if (cmdPtr != NULL) {      if (cmdPtr != NULL) {
2194          if (cmdPtr->nsPtr != NULL) {          if (cmdPtr->nsPtr != NULL) {
2195              Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);              Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
2196              if (cmdPtr->nsPtr != iPtr->globalNsPtr) {              if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
2197                  Tcl_AppendToObj(objPtr, "::", 2);                  Tcl_AppendToObj(objPtr, "::", 2);
2198              }              }
2199          }          }
2200          if (cmdPtr->hPtr != NULL) {          if (cmdPtr->hPtr != NULL) {
2201              name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);              name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
2202              Tcl_AppendToObj(objPtr, name, -1);              Tcl_AppendToObj(objPtr, name, -1);
2203          }          }
2204      }      }
2205  }  }
2206    
2207  /*  /*
2208   *----------------------------------------------------------------------   *----------------------------------------------------------------------
2209   *   *
2210   * Tcl_DeleteCommand --   * Tcl_DeleteCommand --
2211   *   *
2212   *      Remove the given command from the given interpreter.   *      Remove the given command from the given interpreter.
2213   *   *
2214   * Results:   * Results:
2215   *      0 is returned if the command was deleted successfully.   *      0 is returned if the command was deleted successfully.
2216   *      -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.
2217   *   *
2218   * Side effects:   * Side effects:
2219   *      cmdName will no longer be recognized as a valid command for   *      cmdName will no longer be recognized as a valid command for
2220   *      interp.   *      interp.
2221   *   *
2222   *----------------------------------------------------------------------   *----------------------------------------------------------------------
2223   */   */
2224    
2225  int  int
2226  Tcl_DeleteCommand(interp, cmdName)  Tcl_DeleteCommand(interp, cmdName)
2227      Tcl_Interp *interp;         /* Token for command interpreter (returned      Tcl_Interp *interp;         /* Token for command interpreter (returned
2228                                   * by a previous Tcl_CreateInterp call). */                                   * by a previous Tcl_CreateInterp call). */
2229      char *cmdName;              /* Name of command to remove. */      char *cmdName;              /* Name of command to remove. */
2230  {  {
2231      Tcl_Command cmd;      Tcl_Command cmd;
2232    
2233      /*      /*
2234       *  Find the desired command and delete it.       *  Find the desired command and delete it.
2235       */       */
2236    
2237      cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,      cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
2238              /*flags*/ 0);              /*flags*/ 0);
2239      if (cmd == (Tcl_Command) NULL) {      if (cmd == (Tcl_Command) NULL) {
2240          return -1;          return -1;
2241      }      }
2242      return Tcl_DeleteCommandFromToken(interp, cmd);      return Tcl_DeleteCommandFromToken(interp, cmd);
2243  }  }
2244    
2245  /*  /*
2246   *----------------------------------------------------------------------   *----------------------------------------------------------------------
2247   *   *
2248   * Tcl_DeleteCommandFromToken --   * Tcl_DeleteCommandFromToken --
2249   *   *
2250   *      Removes the given command from the given interpreter. This procedure   *      Removes the given command from the given interpreter. This procedure
2251   *      resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead   *      resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead
2252   *      of a command name for efficiency.   *      of a command name for efficiency.
2253   *   *
2254   * Results:   * Results:
2255   *      0 is returned if the command was deleted successfully.   *      0 is returned if the command was deleted successfully.
2256   *      -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.
2257   *   *
2258   * Side effects:   * Side effects:
2259   *      The command specified by "cmd" will no longer be recognized as a   *      The command specified by "cmd" will no longer be recognized as a
2260   *      valid command for "interp".   *      valid command for "interp".
2261   *   *
2262   *----------------------------------------------------------------------   *----------------------------------------------------------------------
2263   */   */
2264    
2265  int  int
2266  Tcl_DeleteCommandFromToken(interp, cmd)  Tcl_DeleteCommandFromToken(interp, cmd)
2267      Tcl_Interp *interp;         /* Token for command interpreter returned by      Tcl_Interp *interp;         /* Token for command interpreter returned by
2268                                   * a previous call to Tcl_CreateInterp. */                                   * a previous call to Tcl_CreateInterp. */
2269      Tcl_Command cmd;            /* Token for command to delete. */      Tcl_Command cmd;            /* Token for command to delete. */
2270  {  {
2271      Interp *iPtr = (Interp *) interp;      Interp *iPtr = (Interp *) interp;
2272      Command *cmdPtr = (Command *) cmd;      Command *cmdPtr = (Command *) cmd;
2273      ImportRef *refPtr, *nextRefPtr;      ImportRef *refPtr, *nextRefPtr;
2274      Tcl_Command importCmd;      Tcl_Command importCmd;
2275    
2276      /*      /*
2277       * The code here is tricky.  We can't delete the hash table entry       * The code here is tricky.  We can't delete the hash table entry
2278       * before invoking the deletion callback because there are cases       * before invoking the deletion callback because there are cases
2279       * where the deletion callback needs to invoke the command (e.g.       * where the deletion callback needs to invoke the command (e.g.
2280       * object systems such as OTcl). However, this means that the       * object systems such as OTcl). However, this means that the
2281       * callback could try to delete or rename the command. The deleted       * callback could try to delete or rename the command. The deleted
2282       * flag allows us to detect these cases and skip nested deletes.       * flag allows us to detect these cases and skip nested deletes.
2283       */       */
2284    
2285      if (cmdPtr->deleted) {      if (cmdPtr->deleted) {
2286          /*          /*
2287           * Another deletion is already in progress.  Remove the hash           * Another deletion is already in progress.  Remove the hash
2288           * table entry now, but don't invoke a callback or free the           * table entry now, but don't invoke a callback or free the
2289           * command structure.           * command structure.
2290           */           */
2291    
2292          Tcl_DeleteHashEntry(cmdPtr->hPtr);          Tcl_DeleteHashEntry(cmdPtr->hPtr);
2293          cmdPtr->hPtr = NULL;          cmdPtr->hPtr = NULL;
2294          return 0;          return 0;
2295      }      }
2296    
2297      /*      /*
2298       * If the command being deleted has a compile procedure, increment the       * If the command being deleted has a compile procedure, increment the
2299       * interpreter's compileEpoch to invalidate its compiled code. This       * interpreter's compileEpoch to invalidate its compiled code. This
2300       * makes sure that we don't later try to execute old code compiled with       * makes sure that we don't later try to execute old code compiled with
2301       * command-specific (i.e., inline) bytecodes for the now-deleted       * command-specific (i.e., inline) bytecodes for the now-deleted
2302       * command. This field is checked in Tcl_EvalObj and ObjInterpProc, and       * command. This field is checked in Tcl_EvalObj and ObjInterpProc, and
2303       * code whose compilation epoch doesn't match is recompiled.       * code whose compilation epoch doesn't match is recompiled.
2304       */       */
2305    
2306      if (cmdPtr->compileProc != NULL) {      if (cmdPtr->compileProc != NULL) {
2307          iPtr->compileEpoch++;          iPtr->compileEpoch++;
2308      }      }
2309    
2310      cmdPtr->deleted = 1;      cmdPtr->deleted = 1;
2311      if (cmdPtr->deleteProc != NULL) {      if (cmdPtr->deleteProc != NULL) {
2312          /*          /*
2313           * Delete the command's client data. If this was an imported command           * Delete the command's client data. If this was an imported command
2314           * created when a command was imported into a namespace, this client           * created when a command was imported into a namespace, this client
2315           * data will be a pointer to a ImportedCmdData structure describing           * data will be a pointer to a ImportedCmdData structure describing
2316           * the "real" command that this imported command refers to.           * the "real" command that this imported command refers to.
2317           */           */
2318                    
2319          /*          /*
2320           * If you are getting a crash during the call to deleteProc and           * If you are getting a crash during the call to deleteProc and
2321           * cmdPtr->deleteProc is a pointer to the function free(), the           * cmdPtr->deleteProc is a pointer to the function free(), the
2322           * most likely cause is that your extension allocated memory           * most likely cause is that your extension allocated memory
2323           * for the clientData argument to Tcl_CreateObjCommand() with           * for the clientData argument to Tcl_CreateObjCommand() with
2324           * the ckalloc() macro and you are now trying to deallocate           * the ckalloc() macro and you are now trying to deallocate
2325           * this memory with free() instead of ckfree(). You should           * this memory with free() instead of ckfree(). You should
2326           * pass a pointer to your own method that calls ckfree().           * pass a pointer to your own method that calls ckfree().
2327           */           */
2328    
2329          (*cmdPtr->deleteProc)(cmdPtr->deleteData);          (*cmdPtr->deleteProc)(cmdPtr->deleteData);
2330      }      }
2331    
2332      /*      /*
2333       * Bump the command epoch counter. This will invalidate all cached       * Bump the command epoch counter. This will invalidate all cached
2334       * references that point to this command.       * references that point to this command.
2335       */       */
2336            
2337      cmdPtr->cmdEpoch++;      cmdPtr->cmdEpoch++;
2338    
2339      /*      /*
2340       * If this command was imported into other namespaces, then imported       * If this command was imported into other namespaces, then imported
2341       * commands were created that refer back to this command. Delete these       * commands were created that refer back to this command. Delete these
2342       * imported commands now.       * imported commands now.
2343       */       */
2344    
2345      for (refPtr = cmdPtr->importRefPtr;  refPtr != NULL;      for (refPtr = cmdPtr->importRefPtr;  refPtr != NULL;
2346              refPtr = nextRefPtr) {              refPtr = nextRefPtr) {
2347          nextRefPtr = refPtr->nextPtr;          nextRefPtr = refPtr->nextPtr;
2348          importCmd = (Tcl_Command) refPtr->importedCmdPtr;          importCmd = (Tcl_Command) refPtr->importedCmdPtr;
2349          Tcl_DeleteCommandFromToken(interp, importCmd);          Tcl_DeleteCommandFromToken(interp, importCmd);
2350      }      }
2351    
2352      /*      /*
2353       * Don't use hPtr to delete the hash entry here, because it's       * Don't use hPtr to delete the hash entry here, because it's
2354       * possible that the deletion callback renamed the command.       * possible that the deletion callback renamed the command.
2355       * Instead, use cmdPtr->hptr, and make sure that no-one else       * Instead, use cmdPtr->hptr, and make sure that no-one else
2356       * has already deleted the hash entry.       * has already deleted the hash entry.
2357       */       */
2358    
2359      if (cmdPtr->hPtr != NULL) {      if (cmdPtr->hPtr != NULL) {
2360          Tcl_DeleteHashEntry(cmdPtr->hPtr);          Tcl_DeleteHashEntry(cmdPtr->hPtr);
2361      }      }
2362    
2363      /*      /*
2364       * Mark the Command structure as no longer valid. This allows       * Mark the Command structure as no longer valid. This allows
2365       * TclExecuteByteCode to recognize when a Command has logically been       * TclExecuteByteCode to recognize when a Command has logically been
2366       * deleted and a pointer to this Command structure cached in a CmdName       * deleted and a pointer to this Command structure cached in a CmdName
2367       * object is invalid. TclExecuteByteCode will look up the command again       * object is invalid. TclExecuteByteCode will look up the command again
2368       * in the interpreter's command hashtable.       * in the interpreter's command hashtable.
2369       */       */
2370    
2371      cmdPtr->objProc = NULL;      cmdPtr->objProc = NULL;
2372    
2373      /*      /*
2374       * Now free the Command structure, unless there is another reference to       * Now free the Command structure, unless there is another reference to
2375       * it from a CmdName Tcl object in some ByteCode code sequence. In that       * it from a CmdName Tcl object in some ByteCode code sequence. In that
2376       * case, delay the cleanup until all references are either discarded       * case, delay the cleanup until all references are either discarded
2377       * (when a ByteCode is freed) or replaced by a new reference (when a       * (when a ByteCode is freed) or replaced by a new reference (when a
2378       * cached CmdName Command reference is found to be invalid and       * cached CmdName Command reference is found to be invalid and
2379       * TclExecuteByteCode looks up the command in the command hashtable).       * TclExecuteByteCode looks up the command in the command hashtable).
2380       */       */
2381            
2382      TclCleanupCommand(cmdPtr);      TclCleanupCommand(cmdPtr);
2383      return 0;      return 0;
2384  }  }
2385    
2386  /*  /*
2387   *----------------------------------------------------------------------   *----------------------------------------------------------------------
2388   *   *
2389   * TclCleanupCommand --   * TclCleanupCommand --
2390   *   *
2391   *      This procedure frees up a Command structure unless it is still   *      This procedure frees up a Command structure unless it is still
2392   *      referenced from an interpreter's command hashtable or from a CmdName   *      referenced from an interpreter's command hashtable or from a CmdName
2393   *      Tcl object representing the name of a command in a ByteCode   *      Tcl object representing the name of a command in a ByteCode
2394   *      instruction sequence.   *      instruction sequence.
2395   *   *
2396   * Results:   * Results:
2397   *      None.   *      None.
2398   *   *
2399   * Side effects:   * Side effects:
2400   *      Memory gets freed unless a reference to the Command structure still   *      Memory gets freed unless a reference to the Command structure still
2401   *      exists. In that case the cleanup is delayed until the command is   *      exists. In that case the cleanup is delayed until the command is
2402   *      deleted or when the last ByteCode referring to it is freed.   *      deleted or when the last ByteCode referring to it is freed.
2403   *   *
2404   *----------------------------------------------------------------------   *----------------------------------------------------------------------
2405   */   */
2406    
2407  void  void
2408  TclCleanupCommand(cmdPtr)  TclCleanupCommand(cmdPtr)
2409      register Command *cmdPtr;   /* Points to the Command structure to      register Command *cmdPtr;   /* Points to the Command structure to
2410                                   * be freed. */                                   * be freed. */
2411  {  {
2412      cmdPtr->refCount--;      cmdPtr->refCount--;
2413      if (cmdPtr->refCount <= 0) {      if (cmdPtr->refCount <= 0) {
2414          ckfree((char *) cmdPtr);          ckfree((char *) cmdPtr);
2415      }      }
2416  }  }
2417    
2418  /*  /*
2419   *----------------------------------------------------------------------   *----------------------------------------------------------------------
2420   *   *
2421   * Tcl_CreateMathFunc --   * Tcl_CreateMathFunc --
2422   *   *
2423   *      Creates a new math function for expressions in a given   *      Creates a new math function for expressions in a given
2424   *      interpreter.   *      interpreter.
2425   *   *
2426   * Results:   * Results:
2427   *      None.   *      None.
2428   *   *
2429   * Side effects:   * Side effects:
2430   *      The function defined by "name" is created or redefined. If the   *      The function defined by "name" is created or redefined. If the
2431   *      function already exists then its definition is replaced; this   *      function already exists then its definition is replaced; this
2432   *      includes the builtin functions. Redefining a builtin function forces   *      includes the builtin functions. Redefining a builtin function forces
2433   *      all existing code to be invalidated since that code may be compiled   *      all existing code to be invalidated since that code may be compiled
2434   *      using an instruction specific to the replaced function. In addition,   *      using an instruction specific to the replaced function. In addition,
2435   *      redefioning a non-builtin function will force existing code to be   *      redefioning a non-builtin function will force existing code to be
2436   *      invalidated if the number of arguments has changed.   *      invalidated if the number of arguments has changed.
2437   *   *
2438   *----------------------------------------------------------------------   *----------------------------------------------------------------------
2439   */   */
2440    
2441  void  void
2442  Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)  Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
2443      Tcl_Interp *interp;                 /* Interpreter in which function is      Tcl_Interp *interp;                 /* Interpreter in which function is
2444                                           * to be available. */                                           * to be available. */
2445      char *name;                         /* Name of function (e.g. "sin"). */      char *name;                         /* Name of function (e.g. "sin"). */
2446      int numArgs;                        /* Nnumber of arguments required by      int numArgs;                        /* Nnumber of arguments required by
2447                                           * function. */                                           * function. */
2448      Tcl_ValueType *argTypes;            /* Array of types acceptable for      Tcl_ValueType *argTypes;            /* Array of types acceptable for
2449                                           * each argument. */                                           * each argument. */
2450      Tcl_MathProc *proc;                 /* Procedure that implements the      Tcl_MathProc *proc;                 /* Procedure that implements the
2451                                           * math function. */                                           * math function. */
2452      ClientData clientData;              /* Additional value to pass to the      ClientData clientData;              /* Additional value to pass to the
2453                                           * function. */                                           * function. */
2454  {  {
2455      Interp *iPtr = (Interp *) interp;      Interp *iPtr = (Interp *) interp;
2456      Tcl_HashEntry *hPtr;      Tcl_HashEntry *hPtr;
2457      MathFunc *mathFuncPtr;      MathFunc *mathFuncPtr;
2458      int new, i;      int new, i;
2459    
2460      hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new);      hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new);
2461      if (new) {      if (new) {
2462          Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc)));          Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc)));
2463      }      }
2464      mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);      mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
2465    
2466      if (!new) {      if (!new) {
2467          if (mathFuncPtr->builtinFuncIndex >= 0) {          if (mathFuncPtr->builtinFuncIndex >= 0) {
2468              /*              /*
2469               * We are redefining a builtin math function. Invalidate the               * We are redefining a builtin math function. Invalidate the
2470               * interpreter's existing code by incrementing its               * interpreter's existing code by incrementing its
2471               * compileEpoch member. This field is checked in Tcl_EvalObj               * compileEpoch member. This field is checked in Tcl_EvalObj
2472               * and ObjInterpProc, and code whose compilation epoch doesn't               * and ObjInterpProc, and code whose compilation epoch doesn't
2473               * match is recompiled. Newly compiled code will no longer               * match is recompiled. Newly compiled code will no longer
2474               * treat the function as builtin.               * treat the function as builtin.
2475               */               */
2476    
2477              iPtr->compileEpoch++;              iPtr->compileEpoch++;
2478          } else {          } else {
2479              /*              /*
2480               * A non-builtin function is being redefined. We must invalidate               * A non-builtin function is being redefined. We must invalidate
2481               * existing code if the number of arguments has changed. This               * existing code if the number of arguments has changed. This
2482               * is because existing code was compiled assuming that number.               * is because existing code was compiled assuming that number.
2483               */               */
2484    
2485              if (numArgs != mathFuncPtr->numArgs) {              if (numArgs != mathFuncPtr->numArgs) {
2486                  iPtr->compileEpoch++;                  iPtr->compileEpoch++;
2487              }              }
2488          }          }
2489      }      }
2490            
2491      mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */      mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */
2492      if (numArgs > MAX_MATH_ARGS) {      if (numArgs > MAX_MATH_ARGS) {
2493          numArgs = MAX_MATH_ARGS;          numArgs = MAX_MATH_ARGS;
2494      }      }
2495      mathFuncPtr->numArgs = numArgs;      mathFuncPtr->numArgs = numArgs;
2496      for (i = 0;  i < numArgs;  i++) {      for (i = 0;  i < numArgs;  i++) {
2497          mathFuncPtr->argTypes[i] = argTypes[i];          mathFuncPtr->argTypes[i] = argTypes[i];
2498      }      }
2499      mathFuncPtr->proc = proc;      mathFuncPtr->proc = proc;
2500      mathFuncPtr->clientData = clientData;      mathFuncPtr->clientData = clientData;
2501  }  }
2502    
2503  /*  /*
2504   *----------------------------------------------------------------------   *----------------------------------------------------------------------
2505   *   *
2506   * Tcl_EvalObjEx --   * Tcl_EvalObjEx --
2507   *   *
2508   *      Execute Tcl commands stored in a Tcl object. These commands are   *      Execute Tcl commands stored in a Tcl object. These commands are
2509   *      compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT   *      compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT
2510   *      is specified.   *      is specified.
2511   *   *
2512   * Results:   * Results:
2513   *      The return value is one of the return codes defined in tcl.h   *      The return value is one of the return codes defined in tcl.h
2514   *      (such as TCL_OK), and the interpreter's result contains a value   *      (such as TCL_OK), and the interpreter's result contains a value
2515   *      to supplement the return code.   *      to supplement the return code.
2516   *   *
2517   * Side effects:   * Side effects:
2518   *      The object is converted, if necessary, to a ByteCode object that   *      The object is converted, if necessary, to a ByteCode object that
2519   *      holds the bytecode instructions for the commands. Executing the   *      holds the bytecode instructions for the commands. Executing the
2520   *      commands will almost certainly have side effects that depend   *      commands will almost certainly have side effects that depend
2521   *      on those commands.   *      on those commands.
2522   *   *
2523   *      Just as in Tcl_Eval, interp->termOffset is set to the offset of the   *      Just as in Tcl_Eval, interp->termOffset is set to the offset of the
2524   *      last character executed in the objPtr's string.   *      last character executed in the objPtr's string.
2525   *   *
2526   *----------------------------------------------------------------------   *----------------------------------------------------------------------
2527   */   */
2528    
2529  int  int
2530  Tcl_EvalObjEx(interp, objPtr, flags)  Tcl_EvalObjEx(interp, objPtr, flags)
2531      Tcl_Interp *interp;                 /* Token for command interpreter      Tcl_Interp *interp;                 /* Token for command interpreter
2532                                           * (returned by a previous call to                                           * (returned by a previous call to
2533                                           * Tcl_CreateInterp). */                                           * Tcl_CreateInterp). */
2534      register Tcl_Obj *objPtr;           /* Pointer to object containing      register Tcl_Obj *objPtr;           /* Pointer to object containing
2535                                           * commands to execute. */                                           * commands to execute. */
2536      int flags;                          /* Collection of OR-ed bits that      int flags;                          /* Collection of OR-ed bits that
2537                                           * control the evaluation of the                                           * control the evaluation of the
2538                                           * script.  Supported values are                                           * script.  Supported values are
2539                                           * TCL_EVAL_GLOBAL and                                           * TCL_EVAL_GLOBAL and
2540                                           * TCL_EVAL_DIRECT. */                                           * TCL_EVAL_DIRECT. */
2541  {  {
2542      register Interp *iPtr = (Interp *) interp;      register Interp *iPtr = (Interp *) interp;
2543      int evalFlags;                      /* Interp->evalFlags value when the      int evalFlags;                      /* Interp->evalFlags value when the
2544                                           * procedure was called. */                                           * procedure was called. */
2545      register ByteCode* codePtr;         /* Tcl Internal type of bytecode. */      register ByteCode* codePtr;         /* Tcl Internal type of bytecode. */
2546      int oldCount = iPtr->cmdCount;      /* Used to tell whether any commands      int oldCount = iPtr->cmdCount;      /* Used to tell whether any commands
2547                                           * at all were executed. */                                           * at all were executed. */
2548      int numSrcBytes;      int numSrcBytes;
2549      int result;      int result;
2550      CallFrame *savedVarFramePtr;        /* Saves old copy of iPtr->varFramePtr      CallFrame *savedVarFramePtr;        /* Saves old copy of iPtr->varFramePtr
2551                                           * in case TCL_EVAL_GLOBAL was set. */                                           * in case TCL_EVAL_GLOBAL was set. */
2552      Namespace *namespacePtr;      Namespace *namespacePtr;
2553    
2554      Tcl_IncrRefCount(objPtr);      Tcl_IncrRefCount(objPtr);
2555    
2556      if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) {      if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) {
2557          /*          /*
2558           * We're not supposed to use the compiler or byte-code interpreter.           * We're not supposed to use the compiler or byte-code interpreter.
2559           * Let Tcl_EvalEx evaluate the command directly (and probably           * Let Tcl_EvalEx evaluate the command directly (and probably
2560           * more slowly).           * more slowly).
2561           *           *
2562           * Pure List Optimization (no string representation).  In this           * Pure List Optimization (no string representation).  In this
2563           * case, we can safely use Tcl_EvalObjv instead and get an           * case, we can safely use Tcl_EvalObjv instead and get an
2564           * appreciable improvement in execution speed.  This is because it           * appreciable improvement in execution speed.  This is because it
2565           * allows us to avoid a setFromAny step that would just pack           * allows us to avoid a setFromAny step that would just pack
2566           * everything into a string and back out again.           * everything into a string and back out again.
2567           *           *
2568           * USE_EVAL_DIRECT is a special flag used for testing purpose only           * USE_EVAL_DIRECT is a special flag used for testing purpose only
2569           * (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt)           * (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt)
2570           */           */
2571          if (!(iPtr->flags & USE_EVAL_DIRECT) &&          if (!(iPtr->flags & USE_EVAL_DIRECT) &&
2572                  (objPtr->typePtr == &tclListType) && /* is a list... */                  (objPtr->typePtr == &tclListType) && /* is a list... */
2573                  (objPtr->bytes == NULL) /* ...without a string rep */) {                  (objPtr->bytes == NULL) /* ...without a string rep */) {
2574              register List *listRepPtr =              register List *listRepPtr =
2575                  (List *) objPtr->internalRep.otherValuePtr;                  (List *) objPtr->internalRep.otherValuePtr;
2576              result = Tcl_EvalObjv(interp, listRepPtr->elemCount,              result = Tcl_EvalObjv(interp, listRepPtr->elemCount,
2577                      listRepPtr->elements, flags);                      listRepPtr->elements, flags);
2578          } else {          } else {
2579              register char *p;              register char *p;
2580              p = Tcl_GetStringFromObj(objPtr, &numSrcBytes);              p = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
2581              result = Tcl_EvalEx(interp, p, numSrcBytes, flags);              result = Tcl_EvalEx(interp, p, numSrcBytes, flags);
2582          }          }
2583          Tcl_DecrRefCount(objPtr);          Tcl_DecrRefCount(objPtr);
2584          return result;          return result;
2585      }      }
2586    
2587      /*      /*
2588       * Prevent the object from being deleted as a side effect of evaling it.       * Prevent the object from being deleted as a side effect of evaling it.
2589       */       */
2590    
2591      savedVarFramePtr = iPtr->varFramePtr;      savedVarFramePtr = iPtr->varFramePtr;
2592      if (flags & TCL_EVAL_GLOBAL) {      if (flags & TCL_EVAL_GLOBAL) {
2593          iPtr->varFramePtr = NULL;          iPtr->varFramePtr = NULL;
2594      }      }
2595    
2596      /*      /*
2597       * Reset both the interpreter's string and object results and clear out       * Reset both the interpreter's string and object results and clear out
2598       * any error information. This makes sure that we return an empty       * any error information. This makes sure that we return an empty
2599       * result if there are no commands in the command string.       * result if there are no commands in the command string.
2600       */       */
2601    
2602      Tcl_ResetResult(interp);      Tcl_ResetResult(interp);
2603    
2604      /*      /*
2605       * Check depth of nested calls to Tcl_Eval:  if this gets too large,       * Check depth of nested calls to Tcl_Eval:  if this gets too large,