util/src/TclTk/tcl8.6.12/generic/tclEnsemble.c

   1 /*
   2  * tclEnsemble.c --
   3  *
   4  *      Contains support for ensembles (see TIP#112), which provide simple
   5  *      mechanism for creating composite commands on top of namespaces.
   6  *
   7  * Copyright (c) 2005-2013 Donal K. Fellows.
   8  *
   9  * See the file "license.terms" for information on usage and redistribution of
  10  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11  */
  12
  13 #include "tclInt.h"
  14 #include "tclCompile.h"
  15
  16 /*
  17  * Declarations for functions local to this file:
  18  */
  19
  20 static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr);
  21 static inline int       EnsembleUnknownCallback(Tcl_Interp *interp,
  22                             EnsembleConfig *ensemblePtr, int objc,
  23                             Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr);
  24 static int              NsEnsembleImplementationCmd(ClientData clientData,
  25                             Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
  26 static int              NsEnsembleImplementationCmdNR(ClientData clientData,
  27                             Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
  28 static void             BuildEnsembleConfig(EnsembleConfig *ensemblePtr);
  29 static int              NsEnsembleStringOrder(const void *strPtr1,
  30                             const void *strPtr2);
  31 static void             DeleteEnsembleConfig(ClientData clientData);
  32 static void             MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
  33                             EnsembleConfig *ensemblePtr, Tcl_HashEntry *hPtr,
  34                             Tcl_Obj *fix);
  35 static void             FreeEnsembleCmdRep(Tcl_Obj *objPtr);
  36 static void             DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
  37 static void             CompileToInvokedCommand(Tcl_Interp *interp,
  38                             Tcl_Parse *parsePtr, Tcl_Obj *replacements,
  39                             Command *cmdPtr, CompileEnv *envPtr);
  40 static int              CompileBasicNArgCommand(Tcl_Interp *interp,
  41                             Tcl_Parse *parsePtr, Command *cmdPtr,
  42                             CompileEnv *envPtr);
  43
  44 static Tcl_NRPostProc   FreeER;
  45
  46 /*
  47  * The lists of subcommands and options for the [namespace ensemble] command.
  48  */
  49
  50 static const char *const ensembleSubcommands[] = {
  51     "configure", "create", "exists", NULL
  52 };
  53 enum EnsSubcmds {
  54     ENS_CONFIG, ENS_CREATE, ENS_EXISTS
  55 };
  56
  57 static const char *const ensembleCreateOptions[] = {
  58     "-command", "-map", "-parameters", "-prefixes", "-subcommands",
  59     "-unknown", NULL
  60 };
  61 enum EnsCreateOpts {
  62     CRT_CMD, CRT_MAP, CRT_PARAM, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN
  63 };
  64
  65 static const char *const ensembleConfigOptions[] = {
  66     "-map", "-namespace", "-parameters", "-prefixes", "-subcommands",
  67     "-unknown", NULL
  68 };
  69 enum EnsConfigOpts {
  70     CONF_MAP, CONF_NAMESPACE, CONF_PARAM, CONF_PREFIX, CONF_SUBCMDS,
  71     CONF_UNKNOWN
  72 };
  73
  74 /*
  75  * This structure defines a Tcl object type that contains a reference to an
  76  * ensemble subcommand (e.g. the "length" in [string length ab]). It is used
  77  * to cache the mapping between the subcommand itself and the real command
  78  * that implements it.
  79  */
  80
  81 static const Tcl_ObjType ensembleCmdType = {
  82     "ensembleCommand",          /* the type's name */
  83     FreeEnsembleCmdRep,         /* freeIntRepProc */
  84     DupEnsembleCmdRep,          /* dupIntRepProc */
  85     NULL,                       /* updateStringProc */
  86     NULL                        /* setFromAnyProc */
  87 };
  88
  89 /*
  90  * The internal rep for caching ensemble subcommand lookups and
  91  * spell corrections.
  92  */
  93
  94 typedef struct {
  95     int epoch;                  /* Used to confirm when the data in this
  96                                  * really structure matches up with the
  97                                  * ensemble. */
  98     Command *token;             /* Reference to the command for which this
  99                                  * structure is a cache of the resolution. */
 100     Tcl_Obj *fix;               /* Corrected spelling, if needed. */
 101     Tcl_HashEntry *hPtr;        /* Direct link to entry in the subcommand
 102                                  * hash table. */
 103 } EnsembleCmdRep;
 104
 105 \f
 106 static inline Tcl_Obj *
 107 NewNsObj(
 108     Tcl_Namespace *namespacePtr)
 109 {
 110     Namespace *nsPtr = (Namespace *) namespacePtr;
 111
 112     if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) {
 113         return Tcl_NewStringObj("::", 2);
 114     } else {
 115         return Tcl_NewStringObj(nsPtr->fullName, -1);
 116     }
 117 }
 118 \f
 119 /*
 120  *----------------------------------------------------------------------
 121  *
 122  * TclNamespaceEnsembleCmd --
 123  *
 124  *      Invoked to implement the "namespace ensemble" command that creates and
 125  *      manipulates ensembles built on top of namespaces. Handles the
 126  *      following syntax:
 127  *
 128  *          namespace ensemble name ?dictionary?
 129  *
 130  * Results:
 131  *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 132  *
 133  * Side effects:
 134  *      Creates the ensemble for the namespace if one did not previously
 135  *      exist. Alternatively, alters the way that the ensemble's subcommand =>
 136  *      implementation prefix is configured.
 137  *
 138  *----------------------------------------------------------------------
 139  */
 140
 141 int
 142 TclNamespaceEnsembleCmd(
 143     ClientData dummy,
 144     Tcl_Interp *interp,
 145     int objc,
 146     Tcl_Obj *const objv[])
 147 {
 148     Tcl_Namespace *namespacePtr;
 149     Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr,
 150         *foundNsPtr, *altFoundNsPtr, *actualCxtPtr;
 151     Tcl_Command token;
 152     Tcl_DictSearch search;
 153     Tcl_Obj *listObj;
 154     const char *simpleName;
 155     int index, done;
 156
 157     if (nsPtr == NULL || nsPtr->flags & NS_DYING) {
 158         if (!Tcl_InterpDeleted(interp)) {
 159             Tcl_SetObjResult(interp, Tcl_NewStringObj(
 160                     "tried to manipulate ensemble of deleted namespace",
 161                     -1));
 162             Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL);
 163         }
 164         return TCL_ERROR;
 165     }
 166
 167     if (objc < 2) {
 168         Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
 169         return TCL_ERROR;
 170     }
 171     if (Tcl_GetIndexFromObj(interp, objv[1], ensembleSubcommands,
 172             "subcommand", 0, &index) != TCL_OK) {
 173         return TCL_ERROR;
 174     }
 175
 176     switch ((enum EnsSubcmds) index) {
 177     case ENS_CREATE: {
 178         const char *name;
 179         int len, allocatedMapFlag = 0;
 180         /*
 181          * Defaults
 182          */
 183         Tcl_Obj *subcmdObj = NULL;
 184         Tcl_Obj *mapObj = NULL;
 185         int permitPrefix = 1;
 186         Tcl_Obj *unknownObj = NULL;
 187         Tcl_Obj *paramObj = NULL;
 188
 189         /*
 190          * Check that we've got option-value pairs... [Bug 1558654]
 191          */
 192
 193         if (objc & 1) {
 194             Tcl_WrongNumArgs(interp, 2, objv, "?option value ...?");
 195             return TCL_ERROR;
 196         }
 197         objv += 2;
 198         objc -= 2;
 199
 200         name = nsPtr->name;
 201         cxtPtr = (Namespace *) nsPtr->parentPtr;
 202
 203         /*
 204          * Parse the option list, applying type checks as we go. Note that we
 205          * are not incrementing any reference counts in the objects at this
 206          * stage, so the presence of an option multiple times won't cause any
 207          * memory leaks.
 208          */
 209
 210         for (; objc>1 ; objc-=2,objv+=2) {
 211             if (Tcl_GetIndexFromObj(interp, objv[0], ensembleCreateOptions,
 212                     "option", 0, &index) != TCL_OK) {
 213                 if (allocatedMapFlag) {
 214                     Tcl_DecrRefCount(mapObj);
 215                 }
 216                 return TCL_ERROR;
 217             }
 218             switch ((enum EnsCreateOpts) index) {
 219             case CRT_CMD:
 220                 name = TclGetString(objv[1]);
 221                 cxtPtr = nsPtr;
 222                 continue;
 223             case CRT_SUBCMDS:
 224                 if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
 225                     if (allocatedMapFlag) {
 226                         Tcl_DecrRefCount(mapObj);
 227                     }
 228                     return TCL_ERROR;
 229                 }
 230                 subcmdObj = (len > 0 ? objv[1] : NULL);
 231                 continue;
 232             case CRT_PARAM:
 233                 if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
 234                     if (allocatedMapFlag) {
 235                         Tcl_DecrRefCount(mapObj);
 236                     }
 237                     return TCL_ERROR;
 238                 }
 239                 paramObj = (len > 0 ? objv[1] : NULL);
 240                 continue;
 241             case CRT_MAP: {
 242                 Tcl_Obj *patchedDict = NULL, *subcmdWordsObj;
 243
 244                 /*
 245                  * Verify that the map is sensible.
 246                  */
 247
 248                 if (Tcl_DictObjFirst(interp, objv[1], &search,
 249                         &subcmdWordsObj, &listObj, &done) != TCL_OK) {
 250                     if (allocatedMapFlag) {
 251                         Tcl_DecrRefCount(mapObj);
 252                     }
 253                     return TCL_ERROR;
 254                 }
 255                 if (done) {
 256                     mapObj = NULL;
 257                     continue;
 258                 }
 259                 do {
 260                     Tcl_Obj **listv;
 261                     const char *cmd;
 262
 263                     if (TclListObjGetElements(interp, listObj, &len,
 264                             &listv) != TCL_OK) {
 265                         Tcl_DictObjDone(&search);
 266                         if (patchedDict) {
 267                             Tcl_DecrRefCount(patchedDict);
 268                         }
 269                         if (allocatedMapFlag) {
 270                             Tcl_DecrRefCount(mapObj);
 271                         }
 272                         return TCL_ERROR;
 273                     }
 274                     if (len < 1) {
 275                         Tcl_SetObjResult(interp, Tcl_NewStringObj(
 276                                 "ensemble subcommand implementations "
 277                                 "must be non-empty lists", -1));
 278                         Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
 279                                 "EMPTY_TARGET", NULL);
 280                         Tcl_DictObjDone(&search);
 281                         if (patchedDict) {
 282                             Tcl_DecrRefCount(patchedDict);
 283                         }
 284                         if (allocatedMapFlag) {
 285                             Tcl_DecrRefCount(mapObj);
 286                         }
 287                         return TCL_ERROR;
 288                     }
 289                     cmd = TclGetString(listv[0]);
 290                     if (!(cmd[0] == ':' && cmd[1] == ':')) {
 291                         Tcl_Obj *newList = Tcl_NewListObj(len, listv);
 292                         Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace *) nsPtr);
 293
 294                         if (nsPtr->parentPtr) {
 295                             Tcl_AppendStringsToObj(newCmd, "::", NULL);
 296                         }
 297                         Tcl_AppendObjToObj(newCmd, listv[0]);
 298                         Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
 299                         if (patchedDict == NULL) {
 300                             patchedDict = Tcl_DuplicateObj(objv[1]);
 301                         }
 302                         Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
 303                                 newList);
 304                     }
 305                     Tcl_DictObjNext(&search, &subcmdWordsObj,&listObj, &done);
 306                 } while (!done);
 307
 308                 if (allocatedMapFlag) {
 309                     Tcl_DecrRefCount(mapObj);
 310                 }
 311                 mapObj = (patchedDict ? patchedDict : objv[1]);
 312                 if (patchedDict) {
 313                     allocatedMapFlag = 1;
 314                 }
 315                 continue;
 316             }
 317             case CRT_PREFIX:
 318                 if (Tcl_GetBooleanFromObj(interp, objv[1],
 319                         &permitPrefix) != TCL_OK) {
 320                     if (allocatedMapFlag) {
 321                         Tcl_DecrRefCount(mapObj);
 322                     }
 323                     return TCL_ERROR;
 324                 }
 325                 continue;
 326             case CRT_UNKNOWN:
 327                 if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
 328                     if (allocatedMapFlag) {
 329                         Tcl_DecrRefCount(mapObj);
 330                     }
 331                     return TCL_ERROR;
 332                 }
 333                 unknownObj = (len > 0 ? objv[1] : NULL);
 334                 continue;
 335             }
 336         }
 337
 338         TclGetNamespaceForQualName(interp, name, cxtPtr,
 339         TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, &actualCxtPtr,
 340         &simpleName);
 341
 342         /*
 343          * Create the ensemble. Note that this might delete another ensemble
 344          * linked to the same namespace, so we must be careful. However, we
 345          * should be OK because we only link the namespace into the list once
 346          * we've created it (and after any deletions have occurred.)
 347          */
 348
 349         token = TclCreateEnsembleInNs(interp, simpleName,
 350              (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr,
 351              (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
 352         Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
 353         Tcl_SetEnsembleMappingDict(interp, token, mapObj);
 354         Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
 355         Tcl_SetEnsembleParameterList(interp, token, paramObj);
 356
 357         /*
 358          * Tricky! Must ensure that the result is not shared (command delete
 359          * traces could have corrupted the pristine object that we started
 360          * with). [Snit test rename-1.5]
 361          */
 362
 363         Tcl_ResetResult(interp);
 364         Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp));
 365         return TCL_OK;
 366     }
 367
 368     case ENS_EXISTS:
 369         if (objc != 3) {
 370             Tcl_WrongNumArgs(interp, 2, objv, "cmdname");
 371             return TCL_ERROR;
 372         }
 373         Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
 374                 Tcl_FindEnsemble(interp, objv[2], 0) != NULL));
 375         return TCL_OK;
 376
 377     case ENS_CONFIG:
 378         if (objc < 3 || (objc != 4 && !(objc & 1))) {
 379             Tcl_WrongNumArgs(interp, 2, objv,
 380                     "cmdname ?-option value ...? ?arg ...?");
 381             return TCL_ERROR;
 382         }
 383         token = Tcl_FindEnsemble(interp, objv[2], TCL_LEAVE_ERR_MSG);
 384         if (token == NULL) {
 385             return TCL_ERROR;
 386         }
 387
 388         if (objc == 4) {
 389             Tcl_Obj *resultObj = NULL;          /* silence gcc 4 warning */
 390
 391             if (Tcl_GetIndexFromObj(interp, objv[3], ensembleConfigOptions,
 392                     "option", 0, &index) != TCL_OK) {
 393                 return TCL_ERROR;
 394             }
 395             switch ((enum EnsConfigOpts) index) {
 396             case CONF_SUBCMDS:
 397                 Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj);
 398                 if (resultObj != NULL) {
 399                     Tcl_SetObjResult(interp, resultObj);
 400                 }
 401                 break;
 402             case CONF_PARAM:
 403                 Tcl_GetEnsembleParameterList(NULL, token, &resultObj);
 404                 if (resultObj != NULL) {
 405                     Tcl_SetObjResult(interp, resultObj);
 406                 }
 407                 break;
 408             case CONF_MAP:
 409                 Tcl_GetEnsembleMappingDict(NULL, token, &resultObj);
 410                 if (resultObj != NULL) {
 411                     Tcl_SetObjResult(interp, resultObj);
 412                 }
 413                 break;
 414             case CONF_NAMESPACE:
 415                 namespacePtr = NULL;            /* silence gcc 4 warning */
 416                 Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
 417                 Tcl_SetObjResult(interp, NewNsObj(namespacePtr));
 418                 break;
 419             case CONF_PREFIX: {
 420                 int flags = 0;                  /* silence gcc 4 warning */
 421
 422                 Tcl_GetEnsembleFlags(NULL, token, &flags);
 423                 Tcl_SetObjResult(interp,
 424                         Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
 425                 break;
 426             }
 427             case CONF_UNKNOWN:
 428                 Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj);
 429                 if (resultObj != NULL) {
 430                     Tcl_SetObjResult(interp, resultObj);
 431                 }
 432                 break;
 433             }
 434         } else if (objc == 3) {
 435             /*
 436              * Produce list of all information.
 437              */
 438
 439             Tcl_Obj *resultObj, *tmpObj = NULL; /* silence gcc 4 warning */
 440             int flags = 0;                      /* silence gcc 4 warning */
 441
 442             TclNewObj(resultObj);
 443
 444             /* -map option */
 445             Tcl_ListObjAppendElement(NULL, resultObj,
 446                     Tcl_NewStringObj(ensembleConfigOptions[CONF_MAP], -1));
 447             Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj);
 448             Tcl_ListObjAppendElement(NULL, resultObj,
 449                     (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
 450
 451             /* -namespace option */
 452             Tcl_ListObjAppendElement(NULL, resultObj,
 453                     Tcl_NewStringObj(ensembleConfigOptions[CONF_NAMESPACE],
 454                             -1));
 455             namespacePtr = NULL;                /* silence gcc 4 warning */
 456             Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
 457             Tcl_ListObjAppendElement(NULL, resultObj, NewNsObj(namespacePtr));
 458
 459             /* -parameters option */
 460             Tcl_ListObjAppendElement(NULL, resultObj,
 461                     Tcl_NewStringObj(ensembleConfigOptions[CONF_PARAM], -1));
 462             Tcl_GetEnsembleParameterList(NULL, token, &tmpObj);
 463             Tcl_ListObjAppendElement(NULL, resultObj,
 464                     (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
 465
 466             /* -prefix option */
 467             Tcl_ListObjAppendElement(NULL, resultObj,
 468                     Tcl_NewStringObj(ensembleConfigOptions[CONF_PREFIX], -1));
 469             Tcl_GetEnsembleFlags(NULL, token, &flags);
 470             Tcl_ListObjAppendElement(NULL, resultObj,
 471                     Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
 472
 473             /* -subcommands option */
 474             Tcl_ListObjAppendElement(NULL, resultObj,
 475                     Tcl_NewStringObj(ensembleConfigOptions[CONF_SUBCMDS],-1));
 476             Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj);
 477             Tcl_ListObjAppendElement(NULL, resultObj,
 478                     (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
 479
 480             /* -unknown option */
 481             Tcl_ListObjAppendElement(NULL, resultObj,
 482                     Tcl_NewStringObj(ensembleConfigOptions[CONF_UNKNOWN],-1));
 483             Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj);
 484             Tcl_ListObjAppendElement(NULL, resultObj,
 485                     (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
 486
 487             Tcl_SetObjResult(interp, resultObj);
 488         } else {
 489             int len, allocatedMapFlag = 0;
 490             Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL,
 491                     *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */
 492             int permitPrefix, flags = 0;        /* silence gcc 4 warning */
 493
 494             Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj);
 495             Tcl_GetEnsembleMappingDict(NULL, token, &mapObj);
 496             Tcl_GetEnsembleParameterList(NULL, token, &paramObj);
 497             Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj);
 498             Tcl_GetEnsembleFlags(NULL, token, &flags);
 499             permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0;
 500
 501             objv += 3;
 502             objc -= 3;
 503
 504             /*
 505              * Parse the option list, applying type checks as we go. Note that
 506              * we are not incrementing any reference counts in the objects at
 507              * this stage, so the presence of an option multiple times won't
 508              * cause any memory leaks.
 509              */
 510
 511             for (; objc>0 ; objc-=2,objv+=2) {
 512                 if (Tcl_GetIndexFromObj(interp, objv[0],ensembleConfigOptions,
 513                         "option", 0, &index) != TCL_OK) {
 514                 freeMapAndError:
 515                     if (allocatedMapFlag) {
 516                         Tcl_DecrRefCount(mapObj);
 517                     }
 518                     return TCL_ERROR;
 519                 }
 520                 switch ((enum EnsConfigOpts) index) {
 521                 case CONF_SUBCMDS:
 522                     if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
 523                         goto freeMapAndError;
 524                     }
 525                     subcmdObj = (len > 0 ? objv[1] : NULL);
 526                     continue;
 527                 case CONF_PARAM:
 528                     if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
 529                         goto freeMapAndError;
 530                     }
 531                     paramObj = (len > 0 ? objv[1] : NULL);
 532                     continue;
 533                 case CONF_MAP: {
 534                     Tcl_Obj *patchedDict = NULL, *subcmdWordsObj, **listv;
 535                     const char *cmd;
 536
 537                     /*
 538                      * Verify that the map is sensible.
 539                      */
 540
 541                     if (Tcl_DictObjFirst(interp, objv[1], &search,
 542                             &subcmdWordsObj, &listObj, &done) != TCL_OK) {
 543                         goto freeMapAndError;
 544                     }
 545                     if (done) {
 546                         mapObj = NULL;
 547                         continue;
 548                     }
 549                     do {
 550                         if (TclListObjGetElements(interp, listObj, &len,
 551                                 &listv) != TCL_OK) {
 552                             Tcl_DictObjDone(&search);
 553                             if (patchedDict) {
 554                                 Tcl_DecrRefCount(patchedDict);
 555                             }
 556                             goto freeMapAndError;
 557                         }
 558                         if (len < 1) {
 559                             Tcl_SetObjResult(interp, Tcl_NewStringObj(
 560                                     "ensemble subcommand implementations "
 561                                     "must be non-empty lists", -1));
 562                             Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
 563                                     "EMPTY_TARGET", NULL);
 564                             Tcl_DictObjDone(&search);
 565                             if (patchedDict) {
 566                                 Tcl_DecrRefCount(patchedDict);
 567                             }
 568                             goto freeMapAndError;
 569                         }
 570                         cmd = TclGetString(listv[0]);
 571                         if (!(cmd[0] == ':' && cmd[1] == ':')) {
 572                             Tcl_Obj *newList = Tcl_DuplicateObj(listObj);
 573                             Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*)nsPtr);
 574
 575                             if (nsPtr->parentPtr) {
 576                                 Tcl_AppendStringsToObj(newCmd, "::", NULL);
 577                             }
 578                             Tcl_AppendObjToObj(newCmd, listv[0]);
 579                             Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd);
 580                             if (patchedDict == NULL) {
 581                                 patchedDict = Tcl_DuplicateObj(objv[1]);
 582                             }
 583                             Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
 584                                     newList);
 585                         }
 586                         Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj,
 587                                 &done);
 588                     } while (!done);
 589                     if (allocatedMapFlag) {
 590                         Tcl_DecrRefCount(mapObj);
 591                     }
 592                     mapObj = (patchedDict ? patchedDict : objv[1]);
 593                     if (patchedDict) {
 594                         allocatedMapFlag = 1;
 595                     }
 596                     continue;
 597                 }
 598                 case CONF_NAMESPACE:
 599                     Tcl_SetObjResult(interp, Tcl_NewStringObj(
 600                             "option -namespace is read-only", -1));
 601                     Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY",
 602                             NULL);
 603                     goto freeMapAndError;
 604                 case CONF_PREFIX:
 605                     if (Tcl_GetBooleanFromObj(interp, objv[1],
 606                             &permitPrefix) != TCL_OK) {
 607                         goto freeMapAndError;
 608                     }
 609                     continue;
 610                 case CONF_UNKNOWN:
 611                     if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
 612                         goto freeMapAndError;
 613                     }
 614                     unknownObj = (len > 0 ? objv[1] : NULL);
 615                     continue;
 616                 }
 617             }
 618
 619             /*
 620              * Update the namespace now that we've finished the parsing stage.
 621              */
 622
 623             flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX
 624                     : flags&~TCL_ENSEMBLE_PREFIX);
 625             Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
 626             Tcl_SetEnsembleMappingDict(interp, token, mapObj);
 627             Tcl_SetEnsembleParameterList(interp, token, paramObj);
 628             Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
 629             Tcl_SetEnsembleFlags(interp, token, flags);
 630         }
 631         return TCL_OK;
 632
 633     default:
 634         Tcl_Panic("unexpected ensemble command");
 635     }
 636     return TCL_OK;
 637 }
 638 \f
 639 /*
 640  *----------------------------------------------------------------------
 641  *
 642  * TclCreateEnsembleInNs --
 643  *
 644  *      Like Tcl_CreateEnsemble, but additionally accepts as an argument the
 645  *      name of the namespace to create the command in.
 646  *
 647  *----------------------------------------------------------------------
 648  */
 649
 650 Tcl_Command
 651 TclCreateEnsembleInNs(
 652     Tcl_Interp *interp,
 653
 654     const char *name,   /* Simple name of command to create (no */
 655                         /* namespace components). */
 656     Tcl_Namespace       /* Name of namespace to create the command in. */
 657     *nameNsPtr,
 658     Tcl_Namespace
 659     *ensembleNsPtr,     /* Name of the namespace for the ensemble. */
 660     int flags
 661     )
 662 {
 663     Namespace *nsPtr = (Namespace *) ensembleNsPtr;
 664     EnsembleConfig *ensemblePtr;
 665     Tcl_Command token;
 666
 667     ensemblePtr = ckalloc(sizeof(EnsembleConfig));
 668     token = TclNRCreateCommandInNs(interp, name,
 669         (Tcl_Namespace *) nameNsPtr, NsEnsembleImplementationCmd,
 670         NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig);
 671     if (token == NULL) {
 672         ckfree(ensemblePtr);
 673         return NULL;
 674     }
 675
 676     ensemblePtr->nsPtr = nsPtr;
 677     ensemblePtr->epoch = 0;
 678     Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS);
 679     ensemblePtr->subcommandArrayPtr = NULL;
 680     ensemblePtr->subcmdList = NULL;
 681     ensemblePtr->subcommandDict = NULL;
 682     ensemblePtr->flags = flags;
 683     ensemblePtr->numParameters = 0;
 684     ensemblePtr->parameterList = NULL;
 685     ensemblePtr->unknownHandler = NULL;
 686     ensemblePtr->token = token;
 687     ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles;
 688     nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr;
 689
 690     /*
 691      * Trigger an eventual recomputation of the ensemble command set. Note
 692      * that this is slightly tricky, as it means that we are not actually
 693      * counting the number of namespace export actions, but it is the simplest
 694      * way to go!
 695      */
 696
 697     nsPtr->exportLookupEpoch++;
 698
 699     if (flags & ENSEMBLE_COMPILE) {
 700         ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble;
 701     }
 702
 703     return ensemblePtr->token;
 704
 705 }
 706
 707
 708 /*
 709  *----------------------------------------------------------------------
 710  *
 711  * Tcl_CreateEnsemble
 712  *
 713  *      Create a simple ensemble attached to the given namespace.
 714  *
 715  *      Deprecated by TclCreateEnsembleInNs.
 716  *
 717  * Value
 718  *
 719  *      The token for the command created.
 720  *
 721  * Effect
 722  *      The ensemble is created and marked for compilation.
 723  *
 724  *
 725  *----------------------------------------------------------------------
 726  */
 727
 728 Tcl_Command
 729 Tcl_CreateEnsemble(
 730     Tcl_Interp *interp,
 731     const char *name,
 732     Tcl_Namespace *namespacePtr,
 733     int flags)
 734 {
 735     Namespace *nsPtr = (Namespace *)namespacePtr, *foundNsPtr, *altNsPtr,
 736         *actualNsPtr;
 737     const char * simpleName;
 738
 739     if (nsPtr == NULL) {
 740         nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
 741     }
 742
 743     TclGetNamespaceForQualName(interp, name, nsPtr, TCL_CREATE_NS_IF_UNKNOWN,
 744         &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName);
 745     return TclCreateEnsembleInNs(interp, simpleName,
 746         (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags);
 747 }
 748
 749 \f
 750 /*
 751  *----------------------------------------------------------------------
 752  *
 753  * Tcl_SetEnsembleSubcommandList --
 754  *
 755  *      Set the subcommand list for a particular ensemble.
 756  *
 757  * Results:
 758  *      Tcl result code (error if command token does not indicate an ensemble
 759  *      or the subcommand list - if non-NULL - is not a list).
 760  *
 761  * Side effects:
 762  *      The ensemble is updated and marked for recompilation.
 763  *
 764  *----------------------------------------------------------------------
 765  */
 766
 767 int
 768 Tcl_SetEnsembleSubcommandList(
 769     Tcl_Interp *interp,
 770     Tcl_Command token,
 771     Tcl_Obj *subcmdList)
 772 {
 773     Command *cmdPtr = (Command *) token;
 774     EnsembleConfig *ensemblePtr;
 775     Tcl_Obj *oldList;
 776
 777     if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
 778         Tcl_SetObjResult(interp, Tcl_NewStringObj(
 779                 "command is not an ensemble", -1));
 780         Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
 781         return TCL_ERROR;
 782     }
 783     if (subcmdList != NULL) {
 784         int length;
 785
 786         if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) {
 787             return TCL_ERROR;
 788         }
 789         if (length < 1) {
 790             subcmdList = NULL;
 791         }
 792     }
 793
 794     ensemblePtr = cmdPtr->objClientData;
 795     oldList = ensemblePtr->subcmdList;
 796     ensemblePtr->subcmdList = subcmdList;
 797     if (subcmdList != NULL) {
 798         Tcl_IncrRefCount(subcmdList);
 799     }
 800     if (oldList != NULL) {
 801         TclDecrRefCount(oldList);
 802     }
 803
 804     /*
 805      * Trigger an eventual recomputation of the ensemble command set. Note
 806      * that this is slightly tricky, as it means that we are not actually
 807      * counting the number of namespace export actions, but it is the simplest
 808      * way to go!
 809      */
 810
 811     ensemblePtr->nsPtr->exportLookupEpoch++;
 812
 813     /*
 814      * Special hack to make compiling of [info exists] work when the
 815      * dictionary is modified.
 816      */
 817
 818     if (cmdPtr->compileProc != NULL) {
 819         ((Interp *) interp)->compileEpoch++;
 820     }
 821
 822     return TCL_OK;
 823 }
 824 \f
 825 /*
 826  *----------------------------------------------------------------------
 827  *
 828  * Tcl_SetEnsembleParameterList --
 829  *
 830  *      Set the parameter list for a particular ensemble.
 831  *
 832  * Results:
 833  *      Tcl result code (error if command token does not indicate an ensemble
 834  *      or the parameter list - if non-NULL - is not a list).
 835  *
 836  * Side effects:
 837  *      The ensemble is updated and marked for recompilation.
 838  *
 839  *----------------------------------------------------------------------
 840  */
 841
 842 int
 843 Tcl_SetEnsembleParameterList(
 844     Tcl_Interp *interp,
 845     Tcl_Command token,
 846     Tcl_Obj *paramList)
 847 {
 848     Command *cmdPtr = (Command *) token;
 849     EnsembleConfig *ensemblePtr;
 850     Tcl_Obj *oldList;
 851     int length;
 852
 853     if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
 854         Tcl_SetObjResult(interp, Tcl_NewStringObj(
 855                 "command is not an ensemble", -1));
 856         Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
 857         return TCL_ERROR;
 858     }
 859     if (paramList == NULL) {
 860         length = 0;
 861     } else {
 862         if (TclListObjLength(interp, paramList, &length) != TCL_OK) {
 863             return TCL_ERROR;
 864         }
 865         if (length < 1) {
 866             paramList = NULL;
 867         }
 868     }
 869
 870     ensemblePtr = cmdPtr->objClientData;
 871     oldList = ensemblePtr->parameterList;
 872     ensemblePtr->parameterList = paramList;
 873     if (paramList != NULL) {
 874         Tcl_IncrRefCount(paramList);
 875     }
 876     if (oldList != NULL) {
 877         TclDecrRefCount(oldList);
 878     }
 879     ensemblePtr->numParameters = length;
 880
 881     /*
 882      * Trigger an eventual recomputation of the ensemble command set. Note
 883      * that this is slightly tricky, as it means that we are not actually
 884      * counting the number of namespace export actions, but it is the simplest
 885      * way to go!
 886      */
 887
 888     ensemblePtr->nsPtr->exportLookupEpoch++;
 889
 890     /*
 891      * Special hack to make compiling of [info exists] work when the
 892      * dictionary is modified.
 893      */
 894
 895     if (cmdPtr->compileProc != NULL) {
 896         ((Interp *) interp)->compileEpoch++;
 897     }
 898
 899     return TCL_OK;
 900 }
 901 \f
 902 /*
 903  *----------------------------------------------------------------------
 904  *
 905  * Tcl_SetEnsembleMappingDict --
 906  *
 907  *      Set the mapping dictionary for a particular ensemble.
 908  *
 909  * Results:
 910  *      Tcl result code (error if command token does not indicate an ensemble
 911  *      or the mapping - if non-NULL - is not a dict).
 912  *
 913  * Side effects:
 914  *      The ensemble is updated and marked for recompilation.
 915  *
 916  *----------------------------------------------------------------------
 917  */
 918
 919 int
 920 Tcl_SetEnsembleMappingDict(
 921     Tcl_Interp *interp,
 922     Tcl_Command token,
 923     Tcl_Obj *mapDict)
 924 {
 925     Command *cmdPtr = (Command *) token;
 926     EnsembleConfig *ensemblePtr;
 927     Tcl_Obj *oldDict;
 928
 929     if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
 930         Tcl_SetObjResult(interp, Tcl_NewStringObj(
 931                 "command is not an ensemble", -1));
 932         Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
 933         return TCL_ERROR;
 934     }
 935     if (mapDict != NULL) {
 936         int size, done;
 937         Tcl_DictSearch search;
 938         Tcl_Obj *valuePtr;
 939
 940         if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) {
 941             return TCL_ERROR;
 942         }
 943
 944         for (Tcl_DictObjFirst(NULL, mapDict, &search, NULL, &valuePtr, &done);
 945                 !done; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) {
 946             Tcl_Obj *cmdObjPtr;
 947             const char *bytes;
 948
 949             if (Tcl_ListObjIndex(interp, valuePtr, 0, &cmdObjPtr) != TCL_OK) {
 950                 Tcl_DictObjDone(&search);
 951                 return TCL_ERROR;
 952             }
 953             bytes = TclGetString(cmdObjPtr);
 954             if (bytes[0] != ':' || bytes[1] != ':') {
 955                 Tcl_SetObjResult(interp, Tcl_NewStringObj(
 956                         "ensemble target is not a fully-qualified command",
 957                         -1));
 958                 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
 959                         "UNQUALIFIED_TARGET", NULL);
 960                 Tcl_DictObjDone(&search);
 961                 return TCL_ERROR;
 962             }
 963         }
 964
 965         if (size < 1) {
 966             mapDict = NULL;
 967         }
 968     }
 969
 970     ensemblePtr = cmdPtr->objClientData;
 971     oldDict = ensemblePtr->subcommandDict;
 972     ensemblePtr->subcommandDict = mapDict;
 973     if (mapDict != NULL) {
 974         Tcl_IncrRefCount(mapDict);
 975     }
 976     if (oldDict != NULL) {
 977         TclDecrRefCount(oldDict);
 978     }
 979
 980     /*
 981      * Trigger an eventual recomputation of the ensemble command set. Note
 982      * that this is slightly tricky, as it means that we are not actually
 983      * counting the number of namespace export actions, but it is the simplest
 984      * way to go!
 985      */
 986
 987     ensemblePtr->nsPtr->exportLookupEpoch++;
 988
 989     /*
 990      * Special hack to make compiling of [info exists] work when the
 991      * dictionary is modified.
 992      */
 993
 994     if (cmdPtr->compileProc != NULL) {
 995         ((Interp *) interp)->compileEpoch++;
 996     }
 997
 998     return TCL_OK;
 999 }
1000 \f
1001 /*
1002  *----------------------------------------------------------------------
1003  *
1004  * Tcl_SetEnsembleUnknownHandler --
1005  *
1006  *      Set the unknown handler for a particular ensemble.
1007  *
1008  * Results:
1009  *      Tcl result code (error if command token does not indicate an ensemble
1010  *      or the unknown handler - if non-NULL - is not a list).
1011  *
1012  * Side effects:
1013  *      The ensemble is updated and marked for recompilation.
1014  *
1015  *----------------------------------------------------------------------
1016  */
1017
1018 int
1019 Tcl_SetEnsembleUnknownHandler(
1020     Tcl_Interp *interp,
1021     Tcl_Command token,
1022     Tcl_Obj *unknownList)
1023 {
1024     Command *cmdPtr = (Command *) token;
1025     EnsembleConfig *ensemblePtr;
1026     Tcl_Obj *oldList;
1027
1028     if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
1029         Tcl_SetObjResult(interp, Tcl_NewStringObj(
1030                 "command is not an ensemble", -1));
1031         Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
1032         return TCL_ERROR;
1033     }
1034     if (unknownList != NULL) {
1035         int length;
1036
1037         if (TclListObjLength(interp, unknownList, &length) != TCL_OK) {
1038             return TCL_ERROR;
1039         }
1040         if (length < 1) {
1041             unknownList = NULL;
1042         }
1043     }
1044
1045     ensemblePtr = cmdPtr->objClientData;
1046     oldList = ensemblePtr->unknownHandler;
1047     ensemblePtr->unknownHandler = unknownList;
1048     if (unknownList != NULL) {
1049         Tcl_IncrRefCount(unknownList);
1050     }
1051     if (oldList != NULL) {
1052         TclDecrRefCount(oldList);
1053     }
1054
1055     /*
1056      * Trigger an eventual recomputation of the ensemble command set. Note
1057      * that this is slightly tricky, as it means that we are not actually
1058      * counting the number of namespace export actions, but it is the simplest
1059      * way to go!
1060      */
1061
1062     ensemblePtr->nsPtr->exportLookupEpoch++;
1063
1064     return TCL_OK;
1065 }
1066 \f
1067 /*
1068  *----------------------------------------------------------------------
1069  *
1070  * Tcl_SetEnsembleFlags --
1071  *
1072  *      Set the flags for a particular ensemble.
1073  *
1074  * Results:
1075  *      Tcl result code (error if command token does not indicate an
1076  *      ensemble).
1077  *
1078  * Side effects:
1079  *      The ensemble is updated and marked for recompilation.
1080  *
1081  *----------------------------------------------------------------------
1082  */
1083
1084 int
1085 Tcl_SetEnsembleFlags(
1086     Tcl_Interp *interp,
1087     Tcl_Command token,
1088     int flags)
1089 {
1090     Command *cmdPtr = (Command *) token;
1091     EnsembleConfig *ensemblePtr;
1092     int wasCompiled;
1093
1094     if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
1095         Tcl_SetObjResult(interp, Tcl_NewStringObj(
1096                 "command is not an ensemble", -1));
1097         Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
1098         return TCL_ERROR;
1099     }
1100
1101     ensemblePtr = cmdPtr->objClientData;
1102     wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE;
1103
1104     /*
1105      * This API refuses to set the ENSEMBLE_DEAD flag...
1106      */
1107
1108     ensemblePtr->flags &= ENSEMBLE_DEAD;
1109     ensemblePtr->flags |= flags & ~ENSEMBLE_DEAD;
1110
1111     /*
1112      * Trigger an eventual recomputation of the ensemble command set. Note
1113      * that this is slightly tricky, as it means that we are not actually
1114      * counting the number of namespace export actions, but it is the simplest
1115      * way to go!
1116      */
1117
1118     ensemblePtr->nsPtr->exportLookupEpoch++;
1119
1120     /*
1121      * If the ENSEMBLE_COMPILE flag status was changed, install or remove the
1122      * compiler function and bump the interpreter's compilation epoch so that
1123      * bytecode gets regenerated.
1124      */
1125
1126     if (flags & ENSEMBLE_COMPILE) {
1127         if (!wasCompiled) {
1128             ((Command*) ensemblePtr->token)->compileProc = TclCompileEnsemble;
1129             ((Interp *) interp)->compileEpoch++;
1130         }
1131     } else {
1132         if (wasCompiled) {
1133             ((Command *) ensemblePtr->token)->compileProc = NULL;
1134             ((Interp *) interp)->compileEpoch++;
1135         }
1136     }
1137
1138     return TCL_OK;
1139 }
1140 \f
1141 /*
1142  *----------------------------------------------------------------------
1143  *
1144  * Tcl_GetEnsembleSubcommandList --
1145  *
1146  *      Get the list of subcommands associated with a particular ensemble.
1147  *
1148  * Results:
1149  *      Tcl result code (error if command token does not indicate an
1150  *      ensemble). The list of subcommands is returned by updating the
1151  *      variable pointed to by the last parameter (NULL if this is to be
1152  *      derived from the mapping dictionary or the associated namespace's
1153  *      exported commands).
1154  *
1155  * Side effects:
1156  *      None
1157  *
1158  *----------------------------------------------------------------------
1159  */
1160
1161 int
1162 Tcl_GetEnsembleSubcommandList(
1163     Tcl_Interp *interp,
1164     Tcl_Command token,
1165     Tcl_Obj **subcmdListPtr)
1166 {
1167     Command *cmdPtr = (Command *) token;
1168     EnsembleConfig *ensemblePtr;
1169
1170     if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
1171         if (interp != NULL) {
1172             Tcl_SetObjResult(interp, Tcl_NewStringObj(
1173                     "command is not an ensemble", -1));
1174             Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
1175         }
1176         return TCL_ERROR;
1177     }
1178
1179     ensemblePtr = cmdPtr->objClientData;
1180     *subcmdListPtr = ensemblePtr->subcmdList;
1181     return TCL_OK;
1182 }
1183 \f
1184 /*
1185  *----------------------------------------------------------------------
1186  *
1187  * Tcl_GetEnsembleParameterList --
1188  *
1189  *      Get the list of parameters associated with a particular ensemble.
1190  *
1191  * Results:
1192  *      Tcl result code (error if command token does not indicate an
1193  *      ensemble). The list of parameters is returned by updating the
1194  *      variable pointed to by the last parameter (NULL if there are
1195  *      no parameters).
1196  *
1197  * Side effects:
1198  *      None
1199  *
1200  *----------------------------------------------------------------------
1201  */
1202
1203 int
1204 Tcl_GetEnsembleParameterList(
1205     Tcl_Interp *interp,
1206     Tcl_Command token,
1207     Tcl_Obj **paramListPtr)
1208 {
1209     Command *cmdPtr = (Command *) token;
1210     EnsembleConfig *ensemblePtr;
1211
1212     if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
1213         if (interp != NULL) {
1214             Tcl_SetObjResult(interp, Tcl_NewStringObj(
1215                     "command is not an ensemble", -1));
1216             Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
1217         }
1218         return TCL_ERROR;
1219     }
1220
1221     ensemblePtr = cmdPtr->objClientData;
1222     *paramListPtr = ensemblePtr->parameterList;
1223     return TCL_OK;
1224 }
1225 \f
1226 /*
1227  *----------------------------------------------------------------------
1228  *
1229  * Tcl_GetEnsembleMappingDict --
1230  *
1231  *      Get the command mapping dictionary associated with a particular
1232  *      ensemble.
1233  *
1234  * Results:
1235  *      Tcl result code (error if command token does not indicate an
1236  *      ensemble). The mapping dict is returned by updating the variable
1237  *      pointed to by the last parameter (NULL if none is installed).
1238  *
1239  * Side effects:
1240  *      None
1241  *
1242  *----------------------------------------------------------------------
1243  */
1244
1245 int
1246 Tcl_GetEnsembleMappingDict(
1247     Tcl_Interp *interp,
1248     Tcl_Command token,
1249     Tcl_Obj **mapDictPtr)
1250 {
1251     Command *cmdPtr = (Command *) token;
1252     EnsembleConfig *ensemblePtr;
1253
1254     if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
1255         if (interp != NULL) {
1256             Tcl_SetObjResult(interp, Tcl_NewStringObj(
1257                     "command is not an ensemble", -1));
1258             Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
1259         }
1260         return TCL_ERROR;
1261     }
1262
1263     ensemblePtr = cmdPtr->objClientData;
1264     *mapDictPtr = ensemblePtr->subcommandDict;
1265     return TCL_OK;
1266 }
1267 \f
1268 /*
1269  *----------------------------------------------------------------------
1270  *
1271  * Tcl_GetEnsembleUnknownHandler --
1272  *
1273  *      Get the unknown handler associated with a particular ensemble.
1274  *
1275  * Results:
1276  *      Tcl result code (error if command token does not indicate an
1277  *      ensemble). The unknown handler is returned by updating the variable
1278  *      pointed to by the last parameter (NULL if no handler is installed).
1279  *
1280  * Side effects:
1281  *      None
1282  *
1283  *----------------------------------------------------------------------
1284  */
1285
1286 int
1287 Tcl_GetEnsembleUnknownHandler(
1288     Tcl_Interp *interp,
1289     Tcl_Command token,
1290     Tcl_Obj **unknownListPtr)
1291 {
1292     Command *cmdPtr = (Command *) token;
1293     EnsembleConfig *ensemblePtr;
1294
1295     if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
1296         if (interp != NULL) {
1297             Tcl_SetObjResult(interp, Tcl_NewStringObj(
1298                     "command is not an ensemble", -1));
1299             Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
1300         }
1301         return TCL_ERROR;
1302     }
1303
1304     ensemblePtr = cmdPtr->objClientData;
1305     *unknownListPtr = ensemblePtr->unknownHandler;
1306     return TCL_OK;
1307 }
1308 \f
1309 /*
1310  *----------------------------------------------------------------------
1311  *
1312  * Tcl_GetEnsembleFlags --
1313  *
1314  *      Get the flags for a particular ensemble.
1315  *
1316  * Results:
1317  *      Tcl result code (error if command token does not indicate an
1318  *      ensemble). The flags are returned by updating the variable pointed to
1319  *      by the last parameter.
1320  *
1321  * Side effects:
1322  *      None
1323  *
1324  *----------------------------------------------------------------------
1325  */
1326
1327 int
1328 Tcl_GetEnsembleFlags(
1329     Tcl_Interp *interp,
1330     Tcl_Command token,
1331     int *flagsPtr)
1332 {
1333     Command *cmdPtr = (Command *) token;
1334     EnsembleConfig *ensemblePtr;
1335
1336     if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
1337         if (interp != NULL) {
1338             Tcl_SetObjResult(interp, Tcl_NewStringObj(
1339                     "command is not an ensemble", -1));
1340             Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
1341         }
1342         return TCL_ERROR;
1343     }
1344
1345     ensemblePtr = cmdPtr->objClientData;
1346     *flagsPtr = ensemblePtr->flags;
1347     return TCL_OK;
1348 }
1349 \f
1350 /*
1351  *----------------------------------------------------------------------
1352  *
1353  * Tcl_GetEnsembleNamespace --
1354  *
1355  *      Get the namespace associated with a particular ensemble.
1356  *
1357  * Results:
1358  *      Tcl result code (error if command token does not indicate an
1359  *      ensemble). Namespace is returned by updating the variable pointed to
1360  *      by the last parameter.
1361  *
1362  * Side effects:
1363  *      None
1364  *
1365  *----------------------------------------------------------------------
1366  */
1367
1368 int
1369 Tcl_GetEnsembleNamespace(
1370     Tcl_Interp *interp,
1371     Tcl_Command token,
1372     Tcl_Namespace **namespacePtrPtr)
1373 {
1374     Command *cmdPtr = (Command *) token;
1375     EnsembleConfig *ensemblePtr;
1376
1377     if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
1378         if (interp != NULL) {
1379             Tcl_SetObjResult(interp, Tcl_NewStringObj(
1380                     "command is not an ensemble", -1));
1381             Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
1382         }
1383         return TCL_ERROR;
1384     }
1385
1386     ensemblePtr = cmdPtr->objClientData;
1387     *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
1388     return TCL_OK;
1389 }
1390 \f
1391 /*
1392  *----------------------------------------------------------------------
1393  *
1394  * Tcl_FindEnsemble --
1395  *
1396  *      Given a command name, get the ensemble token for it, allowing for
1397  *      [namespace import]s. [Bug 1017022]
1398  *
1399  * Results:
1400  *      The token for the ensemble command with the given name, or NULL if the
1401  *      command either does not exist or is not an ensemble (when an error
1402  *      message will be written into the interp if thats non-NULL).
1403  *
1404  * Side effects:
1405  *      None
1406  *
1407  *----------------------------------------------------------------------
1408  */
1409
1410 Tcl_Command
1411 Tcl_FindEnsemble(
1412     Tcl_Interp *interp,         /* Where to do the lookup, and where to write
1413                                  * the errors if TCL_LEAVE_ERR_MSG is set in
1414                                  * the flags. */
1415     Tcl_Obj *cmdNameObj,        /* Name of command to look up. */
1416     int flags)                  /* Either 0 or TCL_LEAVE_ERR_MSG; other flags
1417                                  * are probably not useful. */
1418 {
1419     Command *cmdPtr;
1420
1421     cmdPtr = (Command *)
1422             Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags);
1423     if (cmdPtr == NULL) {
1424         return NULL;
1425     }
1426
1427     if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
1428         /*
1429          * Reuse existing infrastructure for following import link chains
1430          * rather than duplicating it.
1431          */
1432
1433         cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
1434
1435         if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){
1436             if (flags & TCL_LEAVE_ERR_MSG) {
1437                 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1438                         "\"%s\" is not an ensemble command",
1439                         TclGetString(cmdNameObj)));
1440                 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
1441                         TclGetString(cmdNameObj), NULL);
1442             }
1443             return NULL;
1444         }
1445     }
1446
1447     return (Tcl_Command) cmdPtr;
1448 }
1449 \f
1450 /*
1451  *----------------------------------------------------------------------
1452  *
1453  * Tcl_IsEnsemble --
1454  *
1455  *      Simple test for ensemble-hood that takes into account imported
1456  *      ensemble commands as well.
1457  *
1458  * Results:
1459  *      Boolean value
1460  *
1461  * Side effects:
1462  *      None
1463  *
1464  *----------------------------------------------------------------------
1465  */
1466
1467 int
1468 Tcl_IsEnsemble(
1469     Tcl_Command token)
1470 {
1471     Command *cmdPtr = (Command *) token;
1472
1473     if (cmdPtr->objProc == NsEnsembleImplementationCmd) {
1474         return 1;
1475     }
1476     cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
1477     if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
1478         return 0;
1479     }
1480     return 1;
1481 }
1482 \f
1483 /*
1484  *----------------------------------------------------------------------
1485  *
1486  * TclMakeEnsemble --
1487  *
1488  *      Create an ensemble from a table of implementation commands. The
1489  *      ensemble will be subject to (limited) compilation if any of the
1490  *      implementation commands are compilable.
1491  *
1492  *      The 'name' parameter may be a single command name or a list if
1493  *      creating an ensemble subcommand (see the binary implementation).
1494  *
1495  *      Currently, the TCL_ENSEMBLE_PREFIX ensemble flag is only used on
1496  *      top-level ensemble commands.
1497  *
1498  * Results:
1499  *      Handle for the new ensemble, or NULL on failure.
1500  *
1501  * Side effects:
1502  *      May advance the bytecode compilation epoch.
1503  *
1504  *----------------------------------------------------------------------
1505  */
1506
1507 Tcl_Command
1508 TclMakeEnsemble(
1509     Tcl_Interp *interp,
1510     const char *name,            /* The ensemble name (as explained above) */
1511     const EnsembleImplMap map[]) /* The subcommands to create */
1512 {
1513     Tcl_Command ensemble;
1514     Tcl_Namespace *ns;
1515     Tcl_DString buf, hiddenBuf;
1516     const char **nameParts = NULL;
1517     const char *cmdName = NULL;
1518     int i, nameCount = 0, ensembleFlags = 0, hiddenLen;
1519
1520     /*
1521      * Construct the path for the ensemble namespace and create it.
1522      */
1523
1524     Tcl_DStringInit(&buf);
1525     Tcl_DStringInit(&hiddenBuf);
1526     TclDStringAppendLiteral(&hiddenBuf, "tcl:");
1527     Tcl_DStringAppend(&hiddenBuf, name, -1);
1528     TclDStringAppendLiteral(&hiddenBuf, ":");
1529     hiddenLen = Tcl_DStringLength(&hiddenBuf);
1530     if (name[0] == ':' && name[1] == ':') {
1531         /*
1532          * An absolute name, so use it directly.
1533          */
1534
1535         cmdName = name;
1536         Tcl_DStringAppend(&buf, name, -1);
1537         ensembleFlags = TCL_ENSEMBLE_PREFIX;
1538     } else {
1539         /*
1540          * Not an absolute name, so do munging of it. Note that this treats a
1541          * multi-word list differently to a single word.
1542          */
1543
1544         TclDStringAppendLiteral(&buf, "::tcl");
1545
1546         if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) {
1547             Tcl_Panic("invalid ensemble name '%s'", name);
1548         }
1549
1550         for (i = 0; i < nameCount; ++i) {
1551             TclDStringAppendLiteral(&buf, "::");
1552             Tcl_DStringAppend(&buf, nameParts[i], -1);
1553         }
1554     }
1555
1556     ns = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL,
1557             TCL_CREATE_NS_IF_UNKNOWN);
1558     if (!ns) {
1559         Tcl_Panic("unable to find or create %s namespace!",
1560                 Tcl_DStringValue(&buf));
1561     }
1562
1563     /*
1564      * Create the named ensemble in the correct namespace
1565      */
1566
1567     if (cmdName == NULL) {
1568         if (nameCount == 1) {
1569             ensembleFlags = TCL_ENSEMBLE_PREFIX;
1570             cmdName = Tcl_DStringValue(&buf) + 5;
1571         } else {
1572             ns = ns->parentPtr;
1573             cmdName = nameParts[nameCount - 1];
1574         }
1575     }
1576
1577     /*
1578      * Switch on compilation always for core ensembles now that we can do
1579      * nice bytecode things with them.  Do it now.  Waiting until later will
1580      * just cause pointless epoch bumps.
1581      */
1582
1583     ensembleFlags |= ENSEMBLE_COMPILE;
1584     ensemble = Tcl_CreateEnsemble(interp, cmdName, ns, ensembleFlags);
1585
1586     /*
1587      * Create the ensemble mapping dictionary and the ensemble command procs.
1588      */
1589
1590     if (ensemble != NULL) {
1591         Tcl_Obj *mapDict, *fromObj, *toObj;
1592         Command *cmdPtr;
1593
1594         TclDStringAppendLiteral(&buf, "::");
1595         TclNewObj(mapDict);
1596         for (i=0 ; map[i].name != NULL ; i++) {
1597             fromObj = Tcl_NewStringObj(map[i].name, -1);
1598             TclNewStringObj(toObj, Tcl_DStringValue(&buf),
1599                     Tcl_DStringLength(&buf));
1600             Tcl_AppendToObj(toObj, map[i].name, -1);
1601             Tcl_DictObjPut(NULL, mapDict, fromObj, toObj);
1602
1603             if (map[i].proc || map[i].nreProc) {
1604                 /*
1605                  * If the command is unsafe, hide it when we're in a safe
1606                  * interpreter. The code to do this is really hokey! It also
1607                  * doesn't work properly yet; this function is always
1608                  * currently called before the safe-interp flag is set so the
1609                  * Tcl_IsSafe check fails.
1610                  */
1611
1612                 if (map[i].unsafe && Tcl_IsSafe(interp)) {
1613                     cmdPtr = (Command *)
1614                             Tcl_NRCreateCommand(interp, "___tmp", map[i].proc,
1615                             map[i].nreProc, map[i].clientData, NULL);
1616                     Tcl_DStringSetLength(&hiddenBuf, hiddenLen);
1617                     if (Tcl_HideCommand(interp, "___tmp",
1618                             Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) {
1619                         Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
1620                     }
1621                 } else {
1622                     /*
1623                      * Not hidden, so just create it. Yay!
1624                      */
1625
1626                     cmdPtr = (Command *)
1627                             Tcl_NRCreateCommand(interp, TclGetString(toObj),
1628                             map[i].proc, map[i].nreProc, map[i].clientData,
1629                             NULL);
1630                 }
1631                 cmdPtr->compileProc = map[i].compileProc;
1632             }
1633         }
1634         Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
1635     }
1636
1637     Tcl_DStringFree(&buf);
1638     Tcl_DStringFree(&hiddenBuf);
1639     if (nameParts != NULL) {
1640         ckfree((char *) nameParts);
1641     }
1642     return ensemble;
1643 }
1644 \f
1645 /*
1646  *----------------------------------------------------------------------
1647  *
1648  * NsEnsembleImplementationCmd --
1649  *
1650  *      Implements an ensemble of commands (being those exported by a
1651  *      namespace other than the global namespace) as a command with the same
1652  *      (short) name as the namespace in the parent namespace.
1653  *
1654  * Results:
1655  *      A standard Tcl result code. Will be TCL_ERROR if the command is not an
1656  *      unambiguous prefix of any command exported by the ensemble's
1657  *      namespace.
1658  *
1659  * Side effects:
1660  *      Depends on the command within the namespace that gets executed. If the
1661  *      ensemble itself returns TCL_ERROR, a descriptive error message will be
1662  *      placed in the interpreter's result.
1663  *
1664  *----------------------------------------------------------------------
1665  */
1666
1667 static int
1668 NsEnsembleImplementationCmd(
1669     ClientData clientData,
1670     Tcl_Interp *interp,
1671     int objc,
1672     Tcl_Obj *const objv[])
1673 {
1674     return Tcl_NRCallObjProc(interp, NsEnsembleImplementationCmdNR,
1675             clientData, objc, objv);
1676 }
1677
1678 static int
1679 NsEnsembleImplementationCmdNR(
1680     ClientData clientData,
1681     Tcl_Interp *interp,
1682     int objc,
1683     Tcl_Obj *const objv[])
1684 {
1685     EnsembleConfig *ensemblePtr = clientData;
1686                                 /* The ensemble itself. */
1687     Tcl_Obj *prefixObj;         /* An object containing the prefix words of
1688                                  * the command that implements the
1689                                  * subcommand. */
1690     Tcl_HashEntry *hPtr;        /* Used for efficient lookup of fully
1691                                  * specified but not yet cached command
1692                                  * names. */
1693     int reparseCount = 0;       /* Number of reparses. */
1694     Tcl_Obj *errorObj;          /* Used for building error messages. */
1695     Tcl_Obj *subObj;
1696     int subIdx;
1697
1698     /*
1699      * Must recheck objc, since numParameters might have changed. Cf. test
1700      * namespace-53.9.
1701      */
1702
1703   restartEnsembleParse:
1704     subIdx = 1 + ensemblePtr->numParameters;
1705     if (objc < subIdx + 1) {
1706         /*
1707          * We don't have a subcommand argument. Make error message.
1708          */
1709
1710         Tcl_DString buf;        /* Message being built */
1711
1712         Tcl_DStringInit(&buf);
1713         if (ensemblePtr->parameterList) {
1714             Tcl_DStringAppend(&buf,
1715                     TclGetString(ensemblePtr->parameterList), -1);
1716             TclDStringAppendLiteral(&buf, " ");
1717         }
1718         TclDStringAppendLiteral(&buf, "subcommand ?arg ...?");
1719         Tcl_WrongNumArgs(interp, 1, objv, Tcl_DStringValue(&buf));
1720         Tcl_DStringFree(&buf);
1721
1722         return TCL_ERROR;
1723     }
1724
1725     if (ensemblePtr->nsPtr->flags & NS_DYING) {
1726         /*
1727          * Don't know how we got here, but make things give up quickly.
1728          */
1729
1730         if (!Tcl_InterpDeleted(interp)) {
1731             Tcl_SetObjResult(interp, Tcl_NewStringObj(
1732                     "ensemble activated for deleted namespace", -1));
1733             Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL);
1734         }
1735         return TCL_ERROR;
1736     }
1737
1738     /*
1739      * Determine if the table of subcommands is right. If so, we can just look
1740      * up in there and go straight to dispatch.
1741      */
1742
1743     subObj = objv[subIdx];
1744
1745     if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) {
1746         /*
1747          * Table of subcommands is still valid; therefore there might be a
1748          * valid cache of discovered information which we can reuse. Do the
1749          * check here, and if we're still valid, we can jump straight to the
1750          * part where we do the invocation of the subcommand.
1751          */
1752
1753         if (subObj->typePtr==&ensembleCmdType){
1754             EnsembleCmdRep *ensembleCmd = subObj->internalRep.twoPtrValue.ptr1;
1755
1756             if (ensembleCmd->epoch == ensemblePtr->epoch &&
1757                     ensembleCmd->token == (Command *)ensemblePtr->token) {
1758                 prefixObj = Tcl_GetHashValue(ensembleCmd->hPtr);
1759                 Tcl_IncrRefCount(prefixObj);
1760                 if (ensembleCmd->fix) {
1761                     TclSpellFix(interp, objv, objc, subIdx, subObj, ensembleCmd->fix);
1762                 }
1763                 goto runResultingSubcommand;
1764             }
1765         }
1766     } else {
1767         BuildEnsembleConfig(ensemblePtr);
1768         ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch;
1769     }
1770
1771     /*
1772      * Look in the hashtable for the subcommand name; this is the fastest way
1773      * of all if there is no cache in operation.
1774      */
1775
1776     hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
1777             TclGetString(subObj));
1778     if (hPtr != NULL) {
1779
1780         /*
1781          * Cache for later in the subcommand object.
1782          */
1783
1784         MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL);
1785     } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) {
1786         /*
1787          * Could not map, no prefixing, go to unknown/error handling.
1788          */
1789
1790         goto unknownOrAmbiguousSubcommand;
1791     } else {
1792         /*
1793          * If we've not already confirmed the command with the hash as part of
1794          * building our export table, we need to scan the sorted array for
1795          * matches.
1796          */
1797
1798         const char *subcmdName; /* Name of the subcommand, or unique prefix of
1799                                  * it (will be an error for a non-unique
1800                                  * prefix). */
1801         char *fullName = NULL;  /* Full name of the subcommand. */
1802         int stringLength, i;
1803         int tableLength = ensemblePtr->subcommandTable.numEntries;
1804         Tcl_Obj *fix;
1805
1806         subcmdName = Tcl_GetStringFromObj(subObj, &stringLength);
1807         for (i=0 ; i<tableLength ; i++) {
1808             int cmp = strncmp(subcmdName,
1809                     ensemblePtr->subcommandArrayPtr[i],
1810                     (unsigned) stringLength);
1811
1812             if (cmp == 0) {
1813                 if (fullName != NULL) {
1814                     /*
1815                      * Since there's never the exact-match case to worry about
1816                      * (hash search filters this), getting here indicates that
1817                      * our subcommand is an ambiguous prefix of (at least) two
1818                      * exported subcommands, which is an error case.
1819                      */
1820
1821                     goto unknownOrAmbiguousSubcommand;
1822                 }
1823                 fullName = ensemblePtr->subcommandArrayPtr[i];
1824             } else if (cmp < 0) {
1825                 /*
1826                  * Because we are searching a sorted table, we can now stop
1827                  * searching because we have gone past anything that could
1828                  * possibly match.
1829                  */
1830
1831                 break;
1832             }
1833         }
1834         if (fullName == NULL) {
1835             /*
1836              * The subcommand is not a prefix of anything, so bail out!
1837              */
1838
1839             goto unknownOrAmbiguousSubcommand;
1840         }
1841         hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName);
1842         if (hPtr == NULL) {
1843             Tcl_Panic("full name %s not found in supposedly synchronized hash",
1844                     fullName);
1845         }
1846
1847         /*
1848          * Record the spelling correction for usage message.
1849          */
1850
1851         fix = Tcl_NewStringObj(fullName, -1);
1852
1853         /*
1854          * Cache for later in the subcommand object.
1855          */
1856
1857         MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, fix);
1858         TclSpellFix(interp, objv, objc, subIdx, subObj, fix);
1859     }
1860
1861     prefixObj = Tcl_GetHashValue(hPtr);
1862     Tcl_IncrRefCount(prefixObj);
1863   runResultingSubcommand:
1864
1865     /*
1866      * Do the real work of execution of the subcommand by building an array of
1867      * objects (note that this is potentially not the same length as the
1868      * number of arguments to this ensemble command), populating it and then
1869      * feeding it back through the main command-lookup engine. In theory, we
1870      * could look up the command in the namespace ourselves, as we already
1871      * have the namespace in which it is guaranteed to exist,
1872      *
1873      *   ((Q: That's not true if the -map option is used, is it?))
1874      *
1875      * but we don't do that (the cacheing of the command object used should
1876      * help with that.)
1877      */
1878
1879     {
1880         Tcl_Obj *copyPtr;       /* The actual list of words to dispatch to.
1881                                  * Will be freed by the dispatch engine. */
1882         Tcl_Obj **copyObjv;
1883         int copyObjc, prefixObjc;
1884
1885         Tcl_ListObjLength(NULL, prefixObj, &prefixObjc);
1886
1887         if (objc == 2) {
1888             copyPtr = TclListObjCopy(NULL, prefixObj);
1889         } else {
1890             copyPtr = Tcl_NewListObj(objc - 2 + prefixObjc, NULL);
1891             Tcl_ListObjAppendList(NULL, copyPtr, prefixObj);
1892             Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
1893                     ensemblePtr->numParameters, objv + 1);
1894             Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
1895                     objc - 2 - ensemblePtr->numParameters,
1896                     objv + 2 + ensemblePtr->numParameters);
1897         }
1898         Tcl_IncrRefCount(copyPtr);
1899         TclNRAddCallback(interp, TclNRReleaseValues, copyPtr, NULL, NULL, NULL);
1900         TclDecrRefCount(prefixObj);
1901
1902         /*
1903          * Record what arguments the script sent in so that things like
1904          * Tcl_WrongNumArgs can give the correct error message. Parameters
1905          * count both as inserted and removed arguments.
1906          */
1907
1908         if (TclInitRewriteEnsemble(interp, 2 + ensemblePtr->numParameters,
1909                 prefixObjc + ensemblePtr->numParameters, objv)) {
1910             TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL,
1911                     NULL);
1912         }
1913
1914         /*
1915          * Hand off to the target command.
1916          */
1917
1918         TclSkipTailcall(interp);
1919         Tcl_ListObjGetElements(NULL, copyPtr, &copyObjc, &copyObjv);
1920         ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr;
1921         return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL);
1922     }
1923
1924   unknownOrAmbiguousSubcommand:
1925     /*
1926      * Have not been able to match the subcommand asked for with a real
1927      * subcommand that we export. See whether a handler has been registered
1928      * for dealing with this situation. Will only call (at most) once for any
1929      * particular ensemble invocation.
1930      */
1931
1932     if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) {
1933         switch (EnsembleUnknownCallback(interp, ensemblePtr, objc, objv,
1934                 &prefixObj)) {
1935         case TCL_OK:
1936             goto runResultingSubcommand;
1937         case TCL_ERROR:
1938             return TCL_ERROR;
1939         case TCL_CONTINUE:
1940             goto restartEnsembleParse;
1941         }
1942     }
1943
1944     /*
1945      * We cannot determine what subcommand to hand off to, so generate a
1946      * (standard) failure message. Note the one odd case compared with
1947      * standard ensemble-like command, which is where a namespace has no
1948      * exported commands at all...
1949      */
1950
1951     Tcl_ResetResult(interp);
1952     Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
1953             TclGetString(subObj), NULL);
1954     if (ensemblePtr->subcommandTable.numEntries == 0) {
1955         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1956                 "unknown subcommand \"%s\": namespace %s does not"
1957                 " export any commands", TclGetString(subObj),
1958                 ensemblePtr->nsPtr->fullName));
1959         return TCL_ERROR;
1960     }
1961     errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ",
1962             (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""),
1963             TclGetString(subObj));
1964     if (ensemblePtr->subcommandTable.numEntries == 1) {
1965         Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1);
1966     } else {
1967         int i;
1968
1969         for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
1970             Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], -1);
1971             Tcl_AppendToObj(errorObj, ", ", 2);
1972         }
1973         Tcl_AppendPrintfToObj(errorObj, "or %s",
1974                 ensemblePtr->subcommandArrayPtr[i]);
1975     }
1976     Tcl_SetObjResult(interp, errorObj);
1977     return TCL_ERROR;
1978 }
1979
1980 int
1981 TclClearRootEnsemble(
1982     ClientData data[],
1983     Tcl_Interp *interp,
1984     int result)
1985 {
1986     TclResetRewriteEnsemble(interp, 1);
1987     return result;
1988 }
1989 \f
1990 /*
1991  *----------------------------------------------------------------------
1992  *
1993  * TclInitRewriteEnsemble --
1994  *
1995  *      Applies a rewrite of arguments so that an ensemble subcommand will
1996  *      report error messages correctly for the overall command.
1997  *
1998  * Results:
1999  *      Whether this is the first rewrite applied, a value which must be
2000  *      passed to TclResetRewriteEnsemble when undoing this command's
2001  *      behaviour.
2002  *
2003  * Side effects:
2004  *      None.
2005  *
2006  *----------------------------------------------------------------------
2007  */
2008
2009 int
2010 TclInitRewriteEnsemble(
2011     Tcl_Interp *interp,
2012     int numRemoved,
2013     int numInserted,
2014     Tcl_Obj *const *objv)
2015 {
2016     Interp *iPtr = (Interp *) interp;
2017
2018     int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
2019
2020     if (isRootEnsemble) {
2021         iPtr->ensembleRewrite.sourceObjs = objv;
2022         iPtr->ensembleRewrite.numRemovedObjs = numRemoved;
2023         iPtr->ensembleRewrite.numInsertedObjs = numInserted;
2024     } else {
2025         int numIns = iPtr->ensembleRewrite.numInsertedObjs;
2026
2027         if (numIns < numRemoved) {
2028             iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns;
2029             iPtr->ensembleRewrite.numInsertedObjs = numInserted;
2030         } else {
2031             iPtr->ensembleRewrite.numInsertedObjs += numInserted - numRemoved;
2032         }
2033     }
2034     return isRootEnsemble;
2035 }
2036 \f
2037 /*
2038  *----------------------------------------------------------------------
2039  *
2040  * TclResetRewriteEnsemble --
2041  *
2042  *      Removes any rewrites applied to support proper reporting of error
2043  *      messages used in ensembles. Should be paired with
2044  *      TclInitRewriteEnsemble.
2045  *
2046  * Results:
2047  *      None.
2048  *
2049  * Side effects:
2050  *      None.
2051  *
2052  *----------------------------------------------------------------------
2053  */
2054
2055 void
2056 TclResetRewriteEnsemble(
2057     Tcl_Interp *interp,
2058     int isRootEnsemble)
2059 {
2060     Interp *iPtr = (Interp *) interp;
2061
2062     if (isRootEnsemble) {
2063         iPtr->ensembleRewrite.sourceObjs = NULL;
2064         iPtr->ensembleRewrite.numRemovedObjs = 0;
2065         iPtr->ensembleRewrite.numInsertedObjs = 0;
2066     }
2067 }
2068 \f
2069 /*
2070  *----------------------------------------------------------------------
2071  *
2072  * TclSpellFix --
2073  *
2074  *      Record a spelling correction that needs making in the generation of
2075  *      the WrongNumArgs usage message.
2076  *
2077  * Results:
2078  *      None.
2079  *
2080  * Side effects:
2081  *      Can create an alternative ensemble rewrite structure.
2082  *
2083  *----------------------------------------------------------------------
2084  */
2085
2086 static int
2087 FreeER(
2088     ClientData data[],
2089     Tcl_Interp *interp,
2090     int result)
2091 {
2092     Tcl_Obj **tmp = (Tcl_Obj **) data[0];
2093     Tcl_Obj **store = (Tcl_Obj **) data[1];
2094
2095     ckfree(store);
2096     ckfree(tmp);
2097     return result;
2098 }
2099
2100 void
2101 TclSpellFix(
2102     Tcl_Interp *interp,
2103     Tcl_Obj *const *objv,
2104     int objc,
2105     int badIdx,
2106     Tcl_Obj *bad,
2107     Tcl_Obj *fix)
2108 {
2109     Interp *iPtr = (Interp *) interp;
2110     Tcl_Obj *const *search;
2111     Tcl_Obj **store;
2112     int idx;
2113     int size;
2114
2115     if (iPtr->ensembleRewrite.sourceObjs == NULL) {
2116         iPtr->ensembleRewrite.sourceObjs = objv;
2117         iPtr->ensembleRewrite.numRemovedObjs = 0;
2118         iPtr->ensembleRewrite.numInsertedObjs = 0;
2119     }
2120
2121     /*
2122      * Compute the valid length of the ensemble root.
2123      */
2124
2125     size = iPtr->ensembleRewrite.numRemovedObjs + objc
2126                 - iPtr->ensembleRewrite.numInsertedObjs;
2127
2128     search = iPtr->ensembleRewrite.sourceObjs;
2129     if (search[0] == NULL) {
2130         /*
2131          * Awful casting abuse here!
2132          */
2133
2134         search = (Tcl_Obj *const *) search[1];
2135     }
2136
2137     if (badIdx < iPtr->ensembleRewrite.numInsertedObjs) {
2138         /*
2139          * Misspelled value was inserted. We cannot directly jump to the bad
2140          * value, but have to search.
2141          */
2142
2143         idx = 1;
2144         while (idx < size) {
2145             if (search[idx] == bad) {
2146                 break;
2147             }
2148             idx++;
2149         }
2150         if (idx == size) {
2151             return;
2152         }
2153     } else {
2154         /*
2155          * Jump to the misspelled value.
2156          */
2157
2158         idx = iPtr->ensembleRewrite.numRemovedObjs + badIdx
2159                 - iPtr->ensembleRewrite.numInsertedObjs;
2160
2161         /* Verify */
2162         if (search[idx] != bad) {
2163             Tcl_Panic("SpellFix: programming error");
2164         }
2165     }
2166
2167     search = iPtr->ensembleRewrite.sourceObjs;
2168     if (search[0] == NULL) {
2169         store = (Tcl_Obj **) search[2];
2170     }  else {
2171         Tcl_Obj **tmp = ckalloc(3 * sizeof(Tcl_Obj *));
2172
2173         store = ckalloc(size * sizeof(Tcl_Obj *));
2174         memcpy(store, iPtr->ensembleRewrite.sourceObjs,
2175                 size * sizeof(Tcl_Obj *));
2176
2177         /*
2178          * Awful casting abuse here! Note that the NULL in the first element
2179          * indicates that the initial objects are a raw array in the second
2180          * element and the rewritten ones are a raw array in the third.
2181          */
2182
2183         tmp[0] = NULL;
2184         tmp[1] = (Tcl_Obj *) iPtr->ensembleRewrite.sourceObjs;
2185         tmp[2] = (Tcl_Obj *) store;
2186         iPtr->ensembleRewrite.sourceObjs = (Tcl_Obj *const *) tmp;
2187
2188         TclNRAddCallback(interp, FreeER, tmp, store, NULL, NULL);
2189     }
2190
2191     store[idx] = fix;
2192     Tcl_IncrRefCount(fix);
2193     TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL);
2194 }
2195 \f
2196 Tcl_Obj *const *TclEnsembleGetRewriteValues(
2197     Tcl_Interp *interp          /* Current interpreter. */
2198 )
2199 {
2200     Interp *iPtr = (Interp *) interp;
2201     Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs;
2202     if (origObjv[0] == NULL) {
2203         origObjv = (Tcl_Obj *const *)origObjv[2];
2204     }
2205     return origObjv;
2206 }
2207 \f
2208 /*
2209  *----------------------------------------------------------------------
2210  *
2211  * TclFetchEnsembleRoot --
2212  *
2213  *      Returns the root of ensemble rewriting, if any.
2214  *      If no root exists, returns objv instead.
2215  *
2216  * Results:
2217  *      None.
2218  *
2219  * Side effects:
2220  *      None.
2221  *
2222  *----------------------------------------------------------------------
2223  */
2224
2225 Tcl_Obj *const *
2226 TclFetchEnsembleRoot(
2227     Tcl_Interp *interp,
2228     Tcl_Obj *const *objv,
2229     int objc,
2230     int *objcPtr)
2231 {
2232     Tcl_Obj *const *sourceObjs;
2233     Interp *iPtr = (Interp *) interp;
2234
2235     if (iPtr->ensembleRewrite.sourceObjs) {
2236         *objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs
2237                 - iPtr->ensembleRewrite.numInsertedObjs;
2238         if (iPtr->ensembleRewrite.sourceObjs[0] == NULL) {
2239             sourceObjs = (Tcl_Obj *const *)iPtr->ensembleRewrite.sourceObjs[1];
2240         } else {
2241             sourceObjs = iPtr->ensembleRewrite.sourceObjs;
2242         }
2243         return sourceObjs;
2244     }
2245     *objcPtr = objc;
2246     return objv;
2247 }
2248 \f
2249 /*
2250  * ----------------------------------------------------------------------
2251  *
2252  * EnsmebleUnknownCallback --
2253  *
2254  *      Helper for the ensemble engine that handles the procesing of unknown
2255  *      callbacks. See the user documentation of the ensemble unknown handler
2256  *      for details; this function is only ever called when such a function is
2257  *      defined, and is only ever called once per ensemble dispatch (i.e. if a
2258  *      reparse still fails, this isn't called again).
2259  *
2260  * Results:
2261  *      TCL_OK -        *prefixObjPtr contains the command words to dispatch
2262  *                      to.
2263  *      TCL_CONTINUE -  Need to reparse (*prefixObjPtr is invalid).
2264  *      TCL_ERROR -     Something went wrong! Error message in interpreter.
2265  *
2266  * Side effects:
2267  *      Calls the Tcl interpreter, so arbitrary.
2268  *
2269  * ----------------------------------------------------------------------
2270  */
2271
2272 static inline int
2273 EnsembleUnknownCallback(
2274     Tcl_Interp *interp,
2275     EnsembleConfig *ensemblePtr,
2276     int objc,
2277     Tcl_Obj *const objv[],
2278     Tcl_Obj **prefixObjPtr)
2279 {
2280     int paramc, i, result, prefixObjc;
2281     Tcl_Obj **paramv, *unknownCmd, *ensObj;
2282
2283     /*
2284      * Create the unknown command callback to determine what to do.
2285      */
2286
2287     unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);
2288     TclNewObj(ensObj);
2289     Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj);
2290     Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj);
2291     for (i=1 ; i<objc ; i++) {
2292         Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]);
2293     }
2294     TclListObjGetElements(NULL, unknownCmd, &paramc, &paramv);
2295     Tcl_IncrRefCount(unknownCmd);
2296
2297     /*
2298      * Now call the unknown handler. (We don't bother NRE-enabling this; deep
2299      * recursing through unknown handlers is horribly perverse.) Note that it
2300      * is always an error for an unknown handler to delete its ensemble; don't
2301      * do that!
2302      */
2303
2304     Tcl_Preserve(ensemblePtr);
2305     TclSkipTailcall(interp);
2306     result = Tcl_EvalObjv(interp, paramc, paramv, 0);
2307     if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) {
2308         if (!Tcl_InterpDeleted(interp)) {
2309             Tcl_SetObjResult(interp, Tcl_NewStringObj(
2310                     "unknown subcommand handler deleted its ensemble", -1));
2311             Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED",
2312                     NULL);
2313         }
2314         result = TCL_ERROR;
2315     }
2316     Tcl_Release(ensemblePtr);
2317
2318     /*
2319      * If we succeeded, we should either have a list of words that form the
2320      * command to be executed, or an empty list. In the empty-list case, the
2321      * ensemble is believed to be updated so we should ask the ensemble engine
2322      * to reparse the original command.
2323      */
2324
2325     if (result == TCL_OK) {
2326         *prefixObjPtr = Tcl_GetObjResult(interp);
2327         Tcl_IncrRefCount(*prefixObjPtr);
2328         TclDecrRefCount(unknownCmd);
2329         Tcl_ResetResult(interp);
2330
2331         /*
2332          * Namespace is still there. Check if the result is a valid list. If
2333          * it is, and it is non-empty, that list is what we are using as our
2334          * replacement.
2335          */
2336
2337         if (TclListObjLength(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) {
2338             TclDecrRefCount(*prefixObjPtr);
2339             Tcl_AddErrorInfo(interp, "\n    while parsing result of "
2340                     "ensemble unknown subcommand handler");
2341             return TCL_ERROR;
2342         }
2343         if (prefixObjc > 0) {
2344             return TCL_OK;
2345         }
2346
2347         /*
2348          * Namespace alive & empty result => reparse.
2349          */
2350
2351         TclDecrRefCount(*prefixObjPtr);
2352         return TCL_CONTINUE;
2353     }
2354
2355     /*
2356      * Oh no! An exceptional result. Convert to an error.
2357      */
2358
2359     if (!Tcl_InterpDeleted(interp)) {
2360         if (result != TCL_ERROR) {
2361             Tcl_ResetResult(interp);
2362             Tcl_SetObjResult(interp, Tcl_NewStringObj(
2363                     "unknown subcommand handler returned bad code: ", -1));
2364             switch (result) {
2365             case TCL_RETURN:
2366                 Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", -1);
2367                 break;
2368             case TCL_BREAK:
2369                 Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", -1);
2370                 break;
2371             case TCL_CONTINUE:
2372                 Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", -1);
2373                 break;
2374             default:
2375                 Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result);
2376             }
2377             Tcl_AddErrorInfo(interp, "\n    result of "
2378                     "ensemble unknown subcommand handler: ");
2379             Tcl_AppendObjToErrorInfo(interp, unknownCmd);
2380             Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_RESULT",
2381                     NULL);
2382         } else {
2383             Tcl_AddErrorInfo(interp,
2384                     "\n    (ensemble unknown subcommand handler)");
2385         }
2386     }
2387     TclDecrRefCount(unknownCmd);
2388     return TCL_ERROR;
2389 }
2390 \f
2391 /*
2392  *----------------------------------------------------------------------
2393  *
2394  * MakeCachedEnsembleCommand --
2395  *
2396  *      Cache what we've computed so far; it's not nice to repeatedly copy
2397  *      strings about. Note that to do this, we start by deleting any old
2398  *      representation that there was (though if it was an out of date
2399  *      ensemble rep, we can skip some of the deallocation process.)
2400  *
2401  * Results:
2402  *      None
2403  *
2404  * Side effects:
2405  *      Alters the internal representation of the first object parameter.
2406  *
2407  *----------------------------------------------------------------------
2408  */
2409
2410 static void
2411 MakeCachedEnsembleCommand(
2412     Tcl_Obj *objPtr,
2413     EnsembleConfig *ensemblePtr,
2414     Tcl_HashEntry *hPtr,
2415     Tcl_Obj *fix)
2416 {
2417     EnsembleCmdRep *ensembleCmd;
2418
2419     if (objPtr->typePtr == &ensembleCmdType) {
2420         ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
2421         TclCleanupCommandMacro(ensembleCmd->token);
2422         if (ensembleCmd->fix) {
2423             Tcl_DecrRefCount(ensembleCmd->fix);
2424         }
2425     } else {
2426         /*
2427          * Kill the old internal rep, and replace it with a brand new one of
2428          * our own.
2429          */
2430
2431         TclFreeIntRep(objPtr);
2432         ensembleCmd = ckalloc(sizeof(EnsembleCmdRep));
2433         objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd;
2434         objPtr->typePtr = &ensembleCmdType;
2435     }
2436
2437     /*
2438      * Populate the internal rep.
2439      */
2440
2441     ensembleCmd->epoch = ensemblePtr->epoch;
2442     ensembleCmd->token = (Command *) ensemblePtr->token;
2443     ensembleCmd->token->refCount++;
2444     if (fix) {
2445         Tcl_IncrRefCount(fix);
2446     }
2447     ensembleCmd->fix = fix;
2448     ensembleCmd->hPtr = hPtr;
2449 }
2450 \f
2451 /*
2452  *----------------------------------------------------------------------
2453  *
2454  * DeleteEnsembleConfig --
2455  *
2456  *      Destroys the data structure used to represent an ensemble. This is
2457  *      called when the ensemble's command is deleted (which happens
2458  *      automatically if the ensemble's namespace is deleted.) Maintainers
2459  *      should note that ensembles should be deleted by deleting their
2460  *      commands.
2461  *
2462  * Results:
2463  *      None.
2464  *
2465  * Side effects:
2466  *      Memory is (eventually) deallocated.
2467  *
2468  *----------------------------------------------------------------------
2469  */
2470
2471 static void
2472 ClearTable(
2473     EnsembleConfig *ensemblePtr)
2474 {
2475     Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
2476
2477     if (hash->numEntries != 0) {
2478         Tcl_HashSearch search;
2479         Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search);
2480
2481         while (hPtr != NULL) {
2482             Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr);
2483             Tcl_DecrRefCount(prefixObj);
2484             hPtr = Tcl_NextHashEntry(&search);
2485         }
2486         ckfree((char *) ensemblePtr->subcommandArrayPtr);
2487     }
2488     Tcl_DeleteHashTable(hash);
2489 }
2490
2491 static void
2492 DeleteEnsembleConfig(
2493     ClientData clientData)
2494 {
2495     EnsembleConfig *ensemblePtr = clientData;
2496     Namespace *nsPtr = ensemblePtr->nsPtr;
2497
2498     /*
2499      * Unlink from the ensemble chain if it has not been marked as having been
2500      * done already.
2501      */
2502
2503     if (ensemblePtr->next != ensemblePtr) {
2504         EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles;
2505
2506         if (ensPtr == ensemblePtr) {
2507             nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
2508         } else {
2509             while (ensPtr != NULL) {
2510                 if (ensPtr->next == ensemblePtr) {
2511                     ensPtr->next = ensemblePtr->next;
2512                     break;
2513                 }
2514                 ensPtr = ensPtr->next;
2515             }
2516         }
2517     }
2518
2519     /*
2520      * Mark the namespace as dead so code that uses Tcl_Preserve() can tell
2521      * whether disaster happened anyway.
2522      */
2523
2524     ensemblePtr->flags |= ENSEMBLE_DEAD;
2525
2526     /*
2527      * Kill the pointer-containing fields.
2528      */
2529
2530     ClearTable(ensemblePtr);
2531     if (ensemblePtr->subcmdList != NULL) {
2532         Tcl_DecrRefCount(ensemblePtr->subcmdList);
2533     }
2534     if (ensemblePtr->parameterList != NULL) {
2535         Tcl_DecrRefCount(ensemblePtr->parameterList);
2536     }
2537     if (ensemblePtr->subcommandDict != NULL) {
2538         Tcl_DecrRefCount(ensemblePtr->subcommandDict);
2539     }
2540     if (ensemblePtr->unknownHandler != NULL) {
2541         Tcl_DecrRefCount(ensemblePtr->unknownHandler);
2542     }
2543
2544     /*
2545      * Arrange for the structure to be reclaimed. Note that this is complex
2546      * because we have to make sure that we can react sensibly when an
2547      * ensemble is deleted during the process of initialising the ensemble
2548      * (especially the unknown callback.)
2549      */
2550
2551     Tcl_EventuallyFree(ensemblePtr, TCL_DYNAMIC);
2552 }
2553 \f
2554 /*
2555  *----------------------------------------------------------------------
2556  *
2557  * BuildEnsembleConfig --
2558  *
2559  *      Create the internal data structures that describe how an ensemble
2560  *      looks, being a hash mapping from the simple command name to the Tcl list
2561  *      that describes the implementation prefix words, and a sorted array of
2562  *      the names to allow for reasonably efficient unambiguous prefix handling.
2563  *
2564  * Results:
2565  *      None.
2566  *
2567  * Side effects:
2568  *      Reallocates and rebuilds the hash table and array stored at the
2569  *      ensemblePtr argument. For large ensembles or large namespaces, this is
2570  *      a potentially expensive operation.
2571  *
2572  *----------------------------------------------------------------------
2573  */
2574
2575 static void
2576 BuildEnsembleConfig(
2577     EnsembleConfig *ensemblePtr)
2578 {
2579     Tcl_HashSearch search;      /* Used for scanning the set of commands in
2580                                  * the namespace that backs up this
2581                                  * ensemble. */
2582     int i, j, isNew;
2583     Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
2584     Tcl_HashEntry *hPtr;
2585     Tcl_Obj *mapDict = ensemblePtr->subcommandDict;
2586     Tcl_Obj *subList = ensemblePtr->subcmdList;
2587
2588     ClearTable(ensemblePtr);
2589     Tcl_InitHashTable(hash, TCL_STRING_KEYS);
2590
2591     if (subList) {
2592         int subc;
2593         Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj;
2594         char *name;
2595
2596         /*
2597          * There is a list of exactly what subcommands go in the table.
2598          * Must determine the target for each.
2599          */
2600
2601         Tcl_ListObjGetElements(NULL, subList, &subc, &subv);
2602         if (subList == mapDict) {
2603             /*
2604              * Strange case where explicit list of subcommands is same value
2605              * as the dict mapping to targets.
2606              */
2607
2608             for (i = 0; i < subc; i += 2) {
2609                 name = TclGetString(subv[i]);
2610                 hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
2611                 if (!isNew) {
2612                     cmdObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
2613                     Tcl_DecrRefCount(cmdObj);
2614                 }
2615                 Tcl_SetHashValue(hPtr, subv[i+1]);
2616                 Tcl_IncrRefCount(subv[i+1]);
2617
2618                 name = TclGetString(subv[i+1]);
2619                 hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
2620                 if (isNew) {
2621                     cmdObj = Tcl_NewStringObj(name, -1);
2622                     cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
2623                     Tcl_SetHashValue(hPtr, cmdPrefixObj);
2624                     Tcl_IncrRefCount(cmdPrefixObj);
2625                 }
2626             }
2627         } else {
2628             /* Usual case where we can freely act on the list and dict. */
2629
2630             for (i = 0; i < subc; i++) {
2631                 name = TclGetString(subv[i]);
2632                 hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
2633                 if (!isNew) {
2634                     continue;
2635                 }
2636
2637                 /* Lookup target in the dictionary */
2638                 if (mapDict) {
2639                     Tcl_DictObjGet(NULL, mapDict, subv[i], &target);
2640                     if (target) {
2641                         Tcl_SetHashValue(hPtr, target);
2642                         Tcl_IncrRefCount(target);
2643                         continue;
2644                     }
2645                 }
2646
2647                 /*
2648                  * target was not in the dictionary so map onto the namespace.
2649                  * Note in this case that we do not guarantee that the
2650                  * command is actually there; that is the programmer's
2651                  * responsibility (or [::unknown] of course).
2652                  */
2653                 cmdObj = Tcl_NewStringObj(name, -1);
2654                 cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
2655                 Tcl_SetHashValue(hPtr, cmdPrefixObj);
2656                 Tcl_IncrRefCount(cmdPrefixObj);
2657             }
2658         }
2659     } else if (mapDict) {
2660         /*
2661          * No subcmd list, but we do have a mapping dictionary so we should
2662          * use the keys of that. Convert the dictionary's contents into the
2663          * form required for the ensemble's internal hashtable.
2664          */
2665
2666         Tcl_DictSearch dictSearch;
2667         Tcl_Obj *keyObj, *valueObj;
2668         int done;
2669
2670         Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
2671                 &keyObj, &valueObj, &done);
2672         while (!done) {
2673             char *name = TclGetString(keyObj);
2674
2675             hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
2676             Tcl_SetHashValue(hPtr, valueObj);
2677             Tcl_IncrRefCount(valueObj);
2678             Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done);
2679         }
2680     } else {
2681         /*
2682          * Discover what commands are actually exported by the namespace.
2683          * What we have is an array of patterns and a hash table whose keys
2684          * are the command names exported by the namespace (the contents do
2685          * not matter here.) We must find out what commands are actually
2686          * exported by filtering each command in the namespace against each of
2687          * the patterns in the export list. Note that we use an intermediate
2688          * hash table to make memory management easier, and because that makes
2689          * exact matching far easier too.
2690          *
2691          * Suggestion for future enhancement: compute the unique prefixes and
2692          * place them in the hash too, which should make for even faster
2693          * matching.
2694          */
2695
2696         hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
2697         for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
2698             char *nsCmdName =           /* Name of command in namespace. */
2699                     Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);
2700
2701             for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
2702                 if (Tcl_StringMatch(nsCmdName,
2703                         ensemblePtr->nsPtr->exportArrayPtr[i])) {
2704                     hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew);
2705
2706                     /*
2707                      * Remember, hash entries have a full reference to the
2708                      * substituted part of the command (as a list) as their
2709                      * content!
2710                      */
2711
2712                     if (isNew) {
2713                         Tcl_Obj *cmdObj, *cmdPrefixObj;
2714
2715                         TclNewObj(cmdObj);
2716                         Tcl_AppendStringsToObj(cmdObj,
2717                                 ensemblePtr->nsPtr->fullName,
2718                                 (ensemblePtr->nsPtr->parentPtr ? "::" : ""),
2719                                 nsCmdName, NULL);
2720                         cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
2721                         Tcl_SetHashValue(hPtr, cmdPrefixObj);
2722                         Tcl_IncrRefCount(cmdPrefixObj);
2723                     }
2724                     break;
2725                 }
2726             }
2727         }
2728     }
2729
2730     if (hash->numEntries == 0) {
2731         ensemblePtr->subcommandArrayPtr = NULL;
2732         return;
2733     }
2734
2735     /*
2736      * Create a sorted array of all subcommands in the ensemble; hash tables
2737      * are all very well for a quick look for an exact match, but they can't
2738      * determine things like whether a string is a prefix of another (not
2739      * without lots of preparation anyway) and they're no good for when we're
2740      * generating the error message either.
2741      *
2742      * We do this by filling an array with the names (we use the hash keys
2743      * directly to save a copy, since any time we change the array we change
2744      * the hash too, and vice versa) and running quicksort over the array.
2745      */
2746
2747     ensemblePtr->subcommandArrayPtr =
2748             ckalloc(sizeof(char *) * hash->numEntries);
2749
2750     /*
2751      * Fill array from both ends as this makes us less likely to end up with
2752      * performance problems in qsort(), which is good. Note that doing this
2753      * makes this code much more opaque, but the naive alternatve:
2754      *
2755      * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ;
2756      *         hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) {
2757      *     ensemblePtr->subcommandArrayPtr[i] = Tcl_GetHashKey(hash, &hPtr);
2758      * }
2759      *
2760      * can produce long runs of precisely ordered table entries when the
2761      * commands in the namespace are declared in a sorted fashion (an ordering
2762      * some people like) and the hashing functions (or the command names
2763      * themselves) are fairly unfortunate. By filling from both ends, it
2764      * requires active malice (and probably a debugger) to get qsort() to have
2765      * awful runtime behaviour.
2766      */
2767
2768     i = 0;
2769     j = hash->numEntries;
2770     hPtr = Tcl_FirstHashEntry(hash, &search);
2771     while (hPtr != NULL) {
2772         ensemblePtr->subcommandArrayPtr[i++] = Tcl_GetHashKey(hash, hPtr);
2773         hPtr = Tcl_NextHashEntry(&search);
2774         if (hPtr == NULL) {
2775             break;
2776         }
2777         ensemblePtr->subcommandArrayPtr[--j] = Tcl_GetHashKey(hash, hPtr);
2778         hPtr = Tcl_NextHashEntry(&search);
2779     }
2780     if (hash->numEntries > 1) {
2781         qsort(ensemblePtr->subcommandArrayPtr, (unsigned) hash->numEntries,
2782                 sizeof(char *), NsEnsembleStringOrder);
2783     }
2784 }
2785 \f
2786 /*
2787  *----------------------------------------------------------------------
2788  *
2789  * NsEnsembleStringOrder --
2790  *
2791  *      Helper function to compare two pointers to two strings for use with
2792  *      qsort().
2793  *
2794  * Results:
2795  *      -1 if the first string is smaller, 1 if the second string is smaller,
2796  *      and 0 if they are equal.
2797  *
2798  * Side effects:
2799  *      None.
2800  *
2801  *----------------------------------------------------------------------
2802  */
2803
2804 static int
2805 NsEnsembleStringOrder(
2806     const void *strPtr1,
2807     const void *strPtr2)
2808 {
2809     return strcmp(*(const char **)strPtr1, *(const char **)strPtr2);
2810 }
2811 \f
2812 /*
2813  *----------------------------------------------------------------------
2814  *
2815  * FreeEnsembleCmdRep --
2816  *
2817  *      Destroys the internal representation of a Tcl_Obj that has been
2818  *      holding information about a command in an ensemble.
2819  *
2820  * Results:
2821  *      None.
2822  *
2823  * Side effects:
2824  *      Memory is deallocated. If this held the last reference to a
2825  *      namespace's main structure, that main structure will also be
2826  *      destroyed.
2827  *
2828  *----------------------------------------------------------------------
2829  */
2830
2831 static void
2832 FreeEnsembleCmdRep(
2833     Tcl_Obj *objPtr)
2834 {
2835     EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
2836
2837     TclCleanupCommandMacro(ensembleCmd->token);
2838     if (ensembleCmd->fix) {
2839         Tcl_DecrRefCount(ensembleCmd->fix);
2840     }
2841     ckfree(ensembleCmd);
2842     objPtr->typePtr = NULL;
2843 }
2844 \f
2845 /*
2846  *----------------------------------------------------------------------
2847  *
2848  * DupEnsembleCmdRep --
2849  *
2850  *      Makes one Tcl_Obj into a copy of another that is a subcommand of an
2851  *      ensemble.
2852  *
2853  * Results:
2854  *      None.
2855  *
2856  * Side effects:
2857  *      Memory is allocated, and the namespace that the ensemble is built on
2858  *      top of gains another reference.
2859  *
2860  *----------------------------------------------------------------------
2861  */
2862
2863 static void
2864 DupEnsembleCmdRep(
2865     Tcl_Obj *objPtr,
2866     Tcl_Obj *copyPtr)
2867 {
2868     EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
2869     EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep));
2870
2871     copyPtr->typePtr = &ensembleCmdType;
2872     copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy;
2873     ensembleCopy->epoch = ensembleCmd->epoch;
2874     ensembleCopy->token = ensembleCmd->token;
2875     ensembleCopy->token->refCount++;
2876     ensembleCopy->fix = ensembleCmd->fix;
2877     if (ensembleCopy->fix) {
2878         Tcl_IncrRefCount(ensembleCopy->fix);
2879     }
2880     ensembleCopy->hPtr = ensembleCmd->hPtr;
2881 }
2882 \f
2883 /*
2884  *----------------------------------------------------------------------
2885  *
2886  * TclCompileEnsemble --
2887  *
2888  *      Procedure called to compile an ensemble command. Note that most
2889  *      ensembles are not compiled, since modifying a compiled ensemble causes
2890  *      a invalidation of all existing bytecode (expensive!) which is not
2891  *      normally warranted.
2892  *
2893  * Results:
2894  *      Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
2895  *      evaluation to runtime.
2896  *
2897  * Side effects:
2898  *      Instructions are added to envPtr to execute the subcommands of the
2899  *      ensemble at runtime if a compile-time mapping is possible.
2900  *
2901  *----------------------------------------------------------------------
2902  */
2903
2904 int
2905 TclCompileEnsemble(
2906     Tcl_Interp *interp,         /* Used for error reporting. */
2907     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
2908                                  * created by Tcl_ParseCommand. */
2909     Command *cmdPtr,            /* Points to defintion of command being
2910                                  * compiled. */
2911     CompileEnv *envPtr)         /* Holds resulting instructions. */
2912 {
2913     DefineLineInformation;
2914     Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
2915     Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
2916     Tcl_Obj *replaced = Tcl_NewObj(), *replacement;
2917     Tcl_Command ensemble = (Tcl_Command) cmdPtr;
2918     Command *oldCmdPtr = cmdPtr, *newCmdPtr;
2919     int len, result, flags = 0, i, depth = 1, invokeAnyway = 0;
2920     int ourResult = TCL_ERROR;
2921     unsigned numBytes;
2922     const char *word;
2923
2924     Tcl_IncrRefCount(replaced);
2925     if (parsePtr->numWords < depth + 1) {
2926         goto failed;
2927     }
2928     if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
2929         /*
2930          * Too hard.
2931          */
2932
2933         goto failed;
2934     }
2935
2936     /*
2937      * This is where we return to if we are parsing multiple nested compiled
2938      * ensembles. [info object] is such a beast.
2939      */
2940
2941   checkNextWord:
2942     word = tokenPtr[1].start;
2943     numBytes = tokenPtr[1].size;
2944
2945     /*
2946      * There's a sporting chance we'll be able to compile this. But now we
2947      * must check properly. To do that, check that we're compiling an ensemble
2948      * that has a compilable command as its appropriate subcommand.
2949      */
2950
2951     if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK
2952             || mapObj == NULL) {
2953         /*
2954          * Either not an ensemble or a mapping isn't installed. Crud. Too hard
2955          * to proceed.
2956          */
2957
2958         goto failed;
2959     }
2960
2961     /*
2962      * Also refuse to compile anything that uses a formal parameter list for
2963      * now, on the grounds that it is too complex.
2964      */
2965
2966     if (Tcl_GetEnsembleParameterList(NULL, ensemble, &listObj) != TCL_OK
2967             || listObj != NULL) {
2968         /*
2969          * Figuring out how to compile this has become too much. Bail out.
2970          */
2971
2972         goto failed;
2973     }
2974
2975     /*
2976      * Next, get the flags. We need them on several code paths so that we can
2977      * know whether we're to do prefix matching.
2978      */
2979
2980     (void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags);
2981
2982     /*
2983      * Check to see if there's also a subcommand list; must check to see if
2984      * the subcommand we are calling is in that list if it exists, since that
2985      * list filters the entries in the map.
2986      */
2987
2988     (void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
2989     if (listObj != NULL) {
2990         int sclen;
2991         const char *str;
2992         Tcl_Obj *matchObj = NULL;
2993
2994         if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
2995             goto failed;
2996         }
2997         for (i=0 ; i<len ; i++) {
2998             str = Tcl_GetStringFromObj(elems[i], &sclen);
2999             if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) {
3000                 /*
3001                  * Exact match! Excellent!
3002                  */
3003
3004                 result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj);
3005                 if (result != TCL_OK || targetCmdObj == NULL) {
3006                     goto failed;
3007                 }
3008                 replacement = elems[i];
3009                 goto doneMapLookup;
3010             }
3011
3012             /*
3013              * Check to see if we've got a prefix match. A single prefix match
3014              * is fine, and allows us to refine our dictionary lookup, but
3015              * multiple prefix matches is a Bad Thing and will prevent us from
3016              * making progress. Note that we cannot do the lookup immediately
3017              * in the prefix case; might be another entry later in the list
3018              * that causes things to fail.
3019              */
3020
3021             if ((flags & TCL_ENSEMBLE_PREFIX)
3022                     && strncmp(word, str, numBytes) == 0) {
3023                 if (matchObj != NULL) {
3024                     goto failed;
3025                 }
3026                 matchObj = elems[i];
3027             }
3028         }
3029         if (matchObj == NULL) {
3030             goto failed;
3031         }
3032         result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj);
3033         if (result != TCL_OK || targetCmdObj == NULL) {
3034             goto failed;
3035         }
3036         replacement = matchObj;
3037     } else {
3038         Tcl_DictSearch s;
3039         int done, matched;
3040         Tcl_Obj *tmpObj;
3041
3042         /*
3043          * No map, so check the dictionary directly.
3044          */
3045
3046         TclNewStringObj(subcmdObj, word, (int) numBytes);
3047         result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj);
3048         if (result == TCL_OK && targetCmdObj != NULL) {
3049             /*
3050              * Got it. Skip the fiddling around with prefixes.
3051              */
3052
3053             replacement = subcmdObj;
3054             goto doneMapLookup;
3055         }
3056         TclDecrRefCount(subcmdObj);
3057
3058         /*
3059          * We've not literally got a valid subcommand. But maybe we have a
3060          * prefix. Check if prefix matches are allowed.
3061          */
3062
3063         if (!(flags & TCL_ENSEMBLE_PREFIX)) {
3064             goto failed;
3065         }
3066
3067         /*
3068          * Iterate over the keys in the dictionary, checking to see if we're a
3069          * prefix.
3070          */
3071
3072         Tcl_DictObjFirst(NULL, mapObj, &s, &subcmdObj, &tmpObj, &done);
3073         matched = 0;
3074         replacement = NULL;             /* Silence, fool compiler! */
3075         while (!done) {
3076             if (strncmp(TclGetString(subcmdObj), word, numBytes) == 0) {
3077                 if (matched++) {
3078                     /*
3079                      * Must have matched twice! Not unique, so no point
3080                      * looking further.
3081                      */
3082
3083                     break;
3084                 }
3085                 replacement = subcmdObj;
3086                 targetCmdObj = tmpObj;
3087             }
3088             Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done);
3089         }
3090         Tcl_DictObjDone(&s);
3091
3092         /*
3093          * If we have anything other than a single match, we've failed the
3094          * unique prefix check.
3095          */
3096
3097         if (matched != 1) {
3098             invokeAnyway = 1;
3099             goto failed;
3100         }
3101     }
3102
3103     /*
3104      * OK, we definitely map to something. But what?
3105      *
3106      * The command we map to is the first word out of the map element. Note
3107      * that we also reject dealing with multi-element rewrites if we are in a
3108      * safe interpreter, as there is otherwise a (highly gnarly!) way to make
3109      * Tcl crash open to exploit.
3110      */
3111
3112   doneMapLookup:
3113     Tcl_ListObjAppendElement(NULL, replaced, replacement);
3114     if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
3115         goto failed;
3116     } else if (len != 1) {
3117         /*
3118          * Note that at this point we know we can't issue any special
3119          * instruction sequence as the mapping isn't one that we support at
3120          * the compiled level.
3121          */
3122
3123         goto cleanup;
3124     }
3125     targetCmdObj = elems[0];
3126
3127     oldCmdPtr = cmdPtr;
3128     Tcl_IncrRefCount(targetCmdObj);
3129     newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
3130     TclDecrRefCount(targetCmdObj);
3131     if (newCmdPtr == NULL || Tcl_IsSafe(interp)
3132             || newCmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION
3133             || newCmdPtr->flags & CMD_HAS_EXEC_TRACES
3134             || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) {
3135         /*
3136          * Maps to an undefined command or a command without a compiler.
3137          * Cannot compile.
3138          */
3139
3140         goto cleanup;
3141     }
3142     cmdPtr = newCmdPtr;
3143     depth++;
3144
3145     /*
3146      * See whether we have a nested ensemble. If we do, we can go round the
3147      * mulberry bush again, consuming the next word.
3148      */
3149
3150     if (cmdPtr->compileProc == TclCompileEnsemble) {
3151         tokenPtr = TokenAfter(tokenPtr);
3152         if (parsePtr->numWords < depth + 1
3153                 || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
3154             /*
3155              * Too hard because the user has done something unpleasant like
3156              * omitting the sub-ensemble's command name or used a non-constant
3157              * name for a sub-ensemble's command name; we respond by bailing
3158              * out completely (this is a rare case). [Bug 6d2f249a01]
3159              */
3160
3161             goto cleanup;
3162         }
3163         ensemble = (Tcl_Command) cmdPtr;
3164         goto checkNextWord;
3165     }
3166
3167     /*
3168      * Now we've done the mapping process, can now actually try to compile.
3169      * If there is a subcommand compiler and that successfully produces code,
3170      * we'll use that. Otherwise, we fall back to generating opcodes to do the
3171      * invoke at runtime.
3172      */
3173
3174     invokeAnyway = 1;
3175     if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, depth, cmdPtr,
3176             envPtr)) {
3177         ourResult = TCL_OK;
3178         goto cleanup;
3179     }
3180
3181     /*
3182      * Throw out any line information generated by the failed compile attempt.
3183      */
3184
3185     while (mapPtr->nuloc - 1 > eclIndex) {
3186         mapPtr->nuloc--;
3187         ckfree(mapPtr->loc[mapPtr->nuloc].line);
3188         mapPtr->loc[mapPtr->nuloc].line = NULL;
3189     }
3190
3191     /*
3192      * Reset the index of next command.  Toss out any from failed nested
3193      * partial compiles.
3194      */
3195
3196     envPtr->numCommands = mapPtr->nuloc;
3197
3198     /*
3199      * Failed to do a full compile for some reason. Try to do a direct invoke
3200      * instead of going through the ensemble lookup process again.
3201      */
3202
3203   failed:
3204     if (depth < 250) {
3205         if (depth > 1) {
3206             if (!invokeAnyway) {
3207                 cmdPtr = oldCmdPtr;
3208                 depth--;
3209             }
3210         }
3211         /*
3212          * The length of the "replaced" list must be depth-1.  Trim back
3213          * any extra elements that might have been appended by failing
3214          * pathways above.
3215          */
3216         (void) Tcl_ListObjReplace(NULL, replaced, depth-1, LIST_MAX, 0, NULL);
3217
3218         /*
3219          * TODO: Reconsider whether we ought to call CompileToInvokedCommand()
3220          * when depth==1.  In that case we are choosing to emit the
3221          * INST_INVOKE_REPLACE bytecode when there is in fact no replacing
3222          * to be done.  It would be equally functional and presumably more
3223          * performant to fall through to cleanup below, return TCL_ERROR,
3224          * and let the compiler harness emit the INST_INVOKE_STK
3225          * implementation for us.
3226          */
3227
3228         CompileToInvokedCommand(interp, parsePtr, replaced, cmdPtr, envPtr);
3229         ourResult = TCL_OK;
3230     }
3231
3232     /*
3233      * Release the memory we allocated. If we've got here, we've either done
3234      * something useful or we're in a case that we can't compile at all and
3235      * we're just giving up.
3236      */
3237
3238   cleanup:
3239     Tcl_DecrRefCount(replaced);
3240     return ourResult;
3241 }
3242
3243 int
3244 TclAttemptCompileProc(
3245     Tcl_Interp *interp,
3246     Tcl_Parse *parsePtr,
3247     int depth,
3248     Command *cmdPtr,
3249     CompileEnv *envPtr)         /* Holds resulting instructions. */
3250 {
3251     DefineLineInformation;
3252     int result, i;
3253     Tcl_Token *saveTokenPtr = parsePtr->tokenPtr;
3254     int savedStackDepth = envPtr->currStackDepth;
3255     unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
3256     int savedAuxDataArrayNext = envPtr->auxDataArrayNext;
3257     int savedExceptArrayNext = envPtr->exceptArrayNext;
3258 #ifdef TCL_COMPILE_DEBUG
3259     int savedExceptDepth = envPtr->exceptDepth;
3260 #endif
3261
3262     if (cmdPtr->compileProc == NULL) {
3263         return TCL_ERROR;
3264     }
3265
3266     /*
3267      * Advance parsePtr->tokenPtr so that it points at the last subcommand.
3268      * This will be wrong, but it will not matter, and it will put the
3269      * tokens for the arguments in the right place without the needed to
3270      * allocate a synthetic Tcl_Parse struct, or copy tokens around.
3271      */
3272
3273     for (i = 0; i < depth - 1; i++) {
3274         parsePtr->tokenPtr = TokenAfter(parsePtr->tokenPtr);
3275     }
3276     parsePtr->numWords -= (depth - 1);
3277
3278     /*
3279      * Shift the line information arrays to account for different word
3280      * index values.
3281      */
3282
3283     mapPtr->loc[eclIndex].line += (depth - 1);
3284     mapPtr->loc[eclIndex].next += (depth - 1);
3285
3286     /*
3287      * Hand off compilation to the subcommand compiler. At last!
3288      */
3289
3290     result = cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr);
3291
3292     /*
3293      * Undo the shift.
3294      */
3295
3296     mapPtr->loc[eclIndex].line -= (depth - 1);
3297     mapPtr->loc[eclIndex].next -= (depth - 1);
3298
3299     parsePtr->numWords += (depth - 1);
3300     parsePtr->tokenPtr = saveTokenPtr;
3301
3302     /*
3303      * If our target failed to compile, revert any data from failed partial
3304      * compiles.  Note that envPtr->numCommands need not be checked because
3305      * we avoid compiling subcommands that recursively call TclCompileScript().
3306      */
3307
3308 #ifdef TCL_COMPILE_DEBUG
3309     if (envPtr->exceptDepth != savedExceptDepth) {
3310         Tcl_Panic("ExceptionRange Starts and Ends do not balance");
3311     }
3312 #endif
3313
3314     if (result != TCL_OK) {
3315         ExceptionAux *auxPtr = envPtr->exceptAuxArrayPtr;
3316
3317         for (i = 0; i < savedExceptArrayNext; i++) {
3318             while (auxPtr->numBreakTargets > 0
3319                     && auxPtr->breakTargets[auxPtr->numBreakTargets - 1]
3320                     >= savedCodeNext) {
3321                 auxPtr->numBreakTargets--;
3322             }
3323             while (auxPtr->numContinueTargets > 0
3324                     && auxPtr->continueTargets[auxPtr->numContinueTargets - 1]
3325                     >= savedCodeNext) {
3326                 auxPtr->numContinueTargets--;
3327             }
3328             auxPtr++;
3329         }
3330         envPtr->exceptArrayNext = savedExceptArrayNext;
3331
3332         if (savedAuxDataArrayNext != envPtr->auxDataArrayNext) {
3333             AuxData *auxDataPtr = envPtr->auxDataArrayPtr;
3334             AuxData *auxDataEnd = auxDataPtr;
3335
3336             auxDataPtr += savedAuxDataArrayNext;
3337             auxDataEnd += envPtr->auxDataArrayNext;
3338
3339             while (auxDataPtr < auxDataEnd) {
3340                 if (auxDataPtr->type->freeProc != NULL) {
3341                     auxDataPtr->type->freeProc(auxDataPtr->clientData);
3342                 }
3343                 auxDataPtr++;
3344             }
3345             envPtr->auxDataArrayNext = savedAuxDataArrayNext;
3346         }
3347         envPtr->currStackDepth = savedStackDepth;
3348         envPtr->codeNext = envPtr->codeStart + savedCodeNext;
3349 #ifdef TCL_COMPILE_DEBUG
3350     } else {
3351         /*
3352          * Confirm that the command compiler generated a single value on
3353          * the stack as its result. This is only done in debugging mode,
3354          * as it *should* be correct and normal users have no reasonable
3355          * way to fix it anyway.
3356          */
3357
3358         int diff = envPtr->currStackDepth - savedStackDepth;
3359
3360         if (diff != 1) {
3361             Tcl_Panic("bad stack adjustment when compiling"
3362                     " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size,
3363                     parsePtr->tokenPtr->start, diff);
3364         }
3365 #endif
3366     }
3367
3368     return result;
3369 }
3370
3371 /*
3372  * How to compile a subcommand to a _replacing_ invoke of its implementation
3373  * command.
3374  */
3375
3376 static void
3377 CompileToInvokedCommand(
3378     Tcl_Interp *interp,
3379     Tcl_Parse *parsePtr,
3380     Tcl_Obj *replacements,
3381     Command *cmdPtr,
3382     CompileEnv *envPtr)         /* Holds resulting instructions. */
3383 {
3384     DefineLineInformation;
3385     Tcl_Token *tokPtr;
3386     Tcl_Obj *objPtr, **words;
3387     char *bytes;
3388     int length, i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
3389
3390     /*
3391      * Push the words of the command. Take care; the command words may be
3392      * scripts that have backslashes in them, and [info frame 0] can see the
3393      * difference. Hence the call to TclContinuationsEnterDerived...
3394      */
3395
3396     Tcl_ListObjGetElements(NULL, replacements, &numWords, &words);
3397     for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords;
3398             i++, tokPtr = TokenAfter(tokPtr)) {
3399         if (i > 0 && i < numWords+1) {
3400             bytes = Tcl_GetStringFromObj(words[i-1], &length);
3401             PushLiteral(envPtr, bytes, length);
3402             continue;
3403         }
3404
3405         SetLineInformation(i);
3406         if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
3407             int literal = TclRegisterNewLiteral(envPtr,
3408                     tokPtr[1].start, tokPtr[1].size);
3409
3410             if (envPtr->clNext) {
3411                 TclContinuationsEnterDerived(
3412                         TclFetchLiteral(envPtr, literal),
3413                         tokPtr[1].start - envPtr->source,
3414                         envPtr->clNext);
3415             }
3416             TclEmitPush(literal, envPtr);
3417         } else {
3418             CompileTokens(envPtr, tokPtr, interp);
3419         }
3420     }
3421
3422     /*
3423      * Push the name of the command we're actually dispatching to as part of
3424      * the implementation.
3425      */
3426
3427     objPtr = Tcl_NewObj();
3428     Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
3429     bytes = Tcl_GetStringFromObj(objPtr, &length);
3430     if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
3431         extraLiteralFlags |= LITERAL_UNSHARED;
3432     }
3433     cmdLit = TclRegisterLiteral(envPtr, (char *)bytes, length, extraLiteralFlags);
3434     TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
3435     TclEmitPush(cmdLit, envPtr);
3436     TclDecrRefCount(objPtr);
3437
3438     /*
3439      * Do the replacing dispatch.
3440      */
3441
3442     TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,numWords+1);
3443 }
3444 \f
3445 /*
3446  * Helpers that do issuing of instructions for commands that "don't have
3447  * compilers" (well, they do; these). They all work by just generating base
3448  * code to invoke the command; they're intended for ensemble subcommands so
3449  * that the costs of INST_INVOKE_REPLACE can be avoided where we can work out
3450  * that they're not needed.
3451  *
3452  * Note that these are NOT suitable for commands where there's an argument
3453  * that is a script, as an [info level] or [info frame] in the inner context
3454  * can see the difference.
3455  */
3456
3457 static int
3458 CompileBasicNArgCommand(
3459     Tcl_Interp *interp,         /* Used for error reporting. */
3460     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3461                                  * created by Tcl_ParseCommand. */
3462     Command *cmdPtr,            /* Points to defintion of command being
3463                                  * compiled. */
3464     CompileEnv *envPtr)         /* Holds resulting instructions. */
3465 {
3466     Tcl_Obj *objPtr = Tcl_NewObj();
3467
3468     Tcl_IncrRefCount(objPtr);
3469     Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
3470     TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr,
3471             parsePtr->numWords, envPtr);
3472     Tcl_DecrRefCount(objPtr);
3473     return TCL_OK;
3474 }
3475
3476 int
3477 TclCompileBasic0ArgCmd(
3478     Tcl_Interp *interp,         /* Used for error reporting. */
3479     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3480                                  * created by Tcl_ParseCommand. */
3481     Command *cmdPtr,            /* Points to defintion of command being
3482                                  * compiled. */
3483     CompileEnv *envPtr)         /* Holds resulting instructions. */
3484 {
3485     /*
3486      * Verify that the number of arguments is correct; that's the only case
3487      * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3488      * which is the only code that sees the shenanigans of ensemble dispatch.
3489      */
3490
3491     if (parsePtr->numWords != 1) {
3492         return TCL_ERROR;
3493     }
3494
3495     return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3496 }
3497
3498 int
3499 TclCompileBasic1ArgCmd(
3500     Tcl_Interp *interp,         /* Used for error reporting. */
3501     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3502                                  * created by Tcl_ParseCommand. */
3503     Command *cmdPtr,            /* Points to defintion of command being
3504                                  * compiled. */
3505     CompileEnv *envPtr)         /* Holds resulting instructions. */
3506 {
3507     /*
3508      * Verify that the number of arguments is correct; that's the only case
3509      * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3510      * which is the only code that sees the shenanigans of ensemble dispatch.
3511      */
3512
3513     if (parsePtr->numWords != 2) {
3514         return TCL_ERROR;
3515     }
3516
3517     return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3518 }
3519
3520 int
3521 TclCompileBasic2ArgCmd(
3522     Tcl_Interp *interp,         /* Used for error reporting. */
3523     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3524                                  * created by Tcl_ParseCommand. */
3525     Command *cmdPtr,            /* Points to defintion of command being
3526                                  * compiled. */
3527     CompileEnv *envPtr)         /* Holds resulting instructions. */
3528 {
3529     /*
3530      * Verify that the number of arguments is correct; that's the only case
3531      * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3532      * which is the only code that sees the shenanigans of ensemble dispatch.
3533      */
3534
3535     if (parsePtr->numWords != 3) {
3536         return TCL_ERROR;
3537     }
3538
3539     return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3540 }
3541
3542 int
3543 TclCompileBasic3ArgCmd(
3544     Tcl_Interp *interp,         /* Used for error reporting. */
3545     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3546                                  * created by Tcl_ParseCommand. */
3547     Command *cmdPtr,            /* Points to defintion of command being
3548                                  * compiled. */
3549     CompileEnv *envPtr)         /* Holds resulting instructions. */
3550 {
3551     /*
3552      * Verify that the number of arguments is correct; that's the only case
3553      * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3554      * which is the only code that sees the shenanigans of ensemble dispatch.
3555      */
3556
3557     if (parsePtr->numWords != 4) {
3558         return TCL_ERROR;
3559     }
3560
3561     return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3562 }
3563
3564 int
3565 TclCompileBasic0Or1ArgCmd(
3566     Tcl_Interp *interp,         /* Used for error reporting. */
3567     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3568                                  * created by Tcl_ParseCommand. */
3569     Command *cmdPtr,            /* Points to defintion of command being
3570                                  * compiled. */
3571     CompileEnv *envPtr)         /* Holds resulting instructions. */
3572 {
3573     /*
3574      * Verify that the number of arguments is correct; that's the only case
3575      * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3576      * which is the only code that sees the shenanigans of ensemble dispatch.
3577      */
3578
3579     if (parsePtr->numWords != 1 && parsePtr->numWords != 2) {
3580         return TCL_ERROR;
3581     }
3582
3583     return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3584 }
3585
3586 int
3587 TclCompileBasic1Or2ArgCmd(
3588     Tcl_Interp *interp,         /* Used for error reporting. */
3589     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3590                                  * created by Tcl_ParseCommand. */
3591     Command *cmdPtr,            /* Points to defintion of command being
3592                                  * compiled. */
3593     CompileEnv *envPtr)         /* Holds resulting instructions. */
3594 {
3595     /*
3596      * Verify that the number of arguments is correct; that's the only case
3597      * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3598      * which is the only code that sees the shenanigans of ensemble dispatch.
3599      */
3600
3601     if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
3602         return TCL_ERROR;
3603     }
3604
3605     return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3606 }
3607
3608 int
3609 TclCompileBasic2Or3ArgCmd(
3610     Tcl_Interp *interp,         /* Used for error reporting. */
3611     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3612                                  * created by Tcl_ParseCommand. */
3613     Command *cmdPtr,            /* Points to defintion of command being
3614                                  * compiled. */
3615     CompileEnv *envPtr)         /* Holds resulting instructions. */
3616 {
3617     /*
3618      * Verify that the number of arguments is correct; that's the only case
3619      * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3620      * which is the only code that sees the shenanigans of ensemble dispatch.
3621      */
3622
3623     if (parsePtr->numWords != 3 && parsePtr->numWords != 4) {
3624         return TCL_ERROR;
3625     }
3626
3627     return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3628 }
3629
3630 int
3631 TclCompileBasic0To2ArgCmd(
3632     Tcl_Interp *interp,         /* Used for error reporting. */
3633     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3634                                  * created by Tcl_ParseCommand. */
3635     Command *cmdPtr,            /* Points to defintion of command being
3636                                  * compiled. */
3637     CompileEnv *envPtr)         /* Holds resulting instructions. */
3638 {
3639     /*
3640      * Verify that the number of arguments is correct; that's the only case
3641      * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3642      * which is the only code that sees the shenanigans of ensemble dispatch.
3643      */
3644
3645     if (parsePtr->numWords < 1 || parsePtr->numWords > 3) {
3646         return TCL_ERROR;
3647     }
3648
3649     return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3650 }
3651
3652 int
3653 TclCompileBasic1To3ArgCmd(
3654     Tcl_Interp *interp,         /* Used for error reporting. */
3655     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3656                                  * created by Tcl_ParseCommand. */
3657     Command *cmdPtr,            /* Points to defintion of command being
3658                                  * compiled. */
3659     CompileEnv *envPtr)         /* Holds resulting instructions. */
3660 {
3661     /*
3662      * Verify that the number of arguments is correct; that's the only case
3663      * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3664      * which is the only code that sees the shenanigans of ensemble dispatch.
3665      */
3666
3667     if (parsePtr->numWords < 2 || parsePtr->numWords > 4) {
3668         return TCL_ERROR;
3669     }
3670
3671     return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3672 }
3673
3674 int
3675 TclCompileBasicMin0ArgCmd(
3676     Tcl_Interp *interp,         /* Used for error reporting. */
3677     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3678                                  * created by Tcl_ParseCommand. */
3679     Command *cmdPtr,            /* Points to defintion of command being
3680                                  * compiled. */
3681     CompileEnv *envPtr)         /* Holds resulting instructions. */
3682 {
3683     /*
3684      * Verify that the number of arguments is correct; that's the only case
3685      * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3686      * which is the only code that sees the shenanigans of ensemble dispatch.
3687      */
3688
3689     if (parsePtr->numWords < 1) {
3690         return TCL_ERROR;
3691     }
3692
3693     return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3694 }
3695
3696 int
3697 TclCompileBasicMin1ArgCmd(
3698     Tcl_Interp *interp,         /* Used for error reporting. */
3699     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3700                                  * created by Tcl_ParseCommand. */
3701     Command *cmdPtr,            /* Points to defintion of command being
3702                                  * compiled. */
3703     CompileEnv *envPtr)         /* Holds resulting instructions. */
3704 {
3705     /*
3706      * Verify that the number of arguments is correct; that's the only case
3707      * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3708      * which is the only code that sees the shenanigans of ensemble dispatch.
3709      */
3710
3711     if (parsePtr->numWords < 2) {
3712         return TCL_ERROR;
3713     }
3714
3715     return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3716 }
3717
3718 int
3719 TclCompileBasicMin2ArgCmd(
3720     Tcl_Interp *interp,         /* Used for error reporting. */
3721     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
3722                                  * created by Tcl_ParseCommand. */
3723     Command *cmdPtr,            /* Points to defintion of command being
3724                                  * compiled. */
3725     CompileEnv *envPtr)         /* Holds resulting instructions. */
3726 {
3727     /*
3728      * Verify that the number of arguments is correct; that's the only case
3729      * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3730      * which is the only code that sees the shenanigans of ensemble dispatch.
3731      */
3732
3733     if (parsePtr->numWords < 3) {
3734         return TCL_ERROR;
3735     }
3736
3737     return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3738 }
3739 \f
3740 /*
3741  * Local Variables:
3742  * mode: c
3743  * c-basic-offset: 4
3744  * fill-column: 78
3745  * End:
3746  */