From 7a0266fc2a385695a20d43579b3c6951495a3b21 Mon Sep 17 00:00:00 2001 From: escoffon Date: Mon, 5 Oct 1998 22:32:09 +0000 Subject: Added a new Tcl object called "procbody"; this object's internal representation contains both a Proc struct and its associated ByteCode. Updated tclProc.c::TclCreateProc to take procbody instances as the body argument, for future support of compiler extensions. Added the "procbodytest" package for testing all this stuff. --- changes | 16 +- generic/tclInt.h | 4 +- generic/tclObj.c | 3 +- generic/tclProc.c | 506 +++++++++++++++++++++++++++++++++---------- generic/tclTestProcBodyObj.c | 317 +++++++++++++++++++++++++++ tests/proc.test | 132 ++++++++++- unix/Makefile.in | 11 +- unix/tclAppInit.c | 9 +- win/makefile.vc | 3 +- win/tclAppInit.c | 9 +- 10 files changed, 881 insertions(+), 129 deletions(-) create mode 100644 generic/tclTestProcBodyObj.c diff --git a/changes b/changes index 6ea7ece..31f8f87 100644 --- a/changes +++ b/changes @@ -1,6 +1,6 @@ Recent user-visible changes to Tcl: -RCS: @(#) $Id: changes,v 1.22 1998/09/30 23:59:08 stanton Exp $ +RCS: @(#) $Id: changes,v 1.23 1998/10/05 22:32:56 escoffon Exp $ 1. No more [command1] [command2] construct for grouping multiple commands on a single command line. @@ -3611,5 +3611,15 @@ GlobalReAlloc API was not correctly re-allocating blocks that were 32k+. The fix was to use newer Win32 APIs (HeapAlloc, HeapFree, and HeapReAlloc.) (BS) -======== Changes for 8.0 go above this line ======== -======== Changes for 8.1 go below this line ======== +10/5/98 (bug fix) Fixed bug in pkg_mkIndex that caused some files that do +a "package require" of packages in the Tcl libraries to give a warning like + warning: "xx.tcl" provides more than one package ({xx 2.0} {yy 0.3}) +and generate a broken pkgIndex.tcl file. (EMS) + +10/5/98 (bug fix) Pkg_mkIndex was not doing a case-insensitive comparison +of extensions to determine whether to load or source a file. Thus, under +Windows, MYDLLNAME.DLL was sourced, and mydllname.dll loaded. (EMS) + +10/5/98 (new feature) Created a new Tcl_Obj type, "procbody". This object's +internal representation holds a pointer to a Proc structure. Extended +TclCreateProc to take both strings and "procbody" diff --git a/generic/tclInt.h b/generic/tclInt.h index 542e68c..4c4d632 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.18 1998/09/29 18:22:39 rjohnson Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.19 1998/10/05 22:32:09 escoffon Exp $ */ #ifndef _TCLINT @@ -1388,6 +1388,7 @@ extern Tcl_ObjType tclByteCodeType; extern Tcl_ObjType tclDoubleType; extern Tcl_ObjType tclIntType; extern Tcl_ObjType tclListType; +extern Tcl_ObjType tclProcBodyType; extern Tcl_ObjType tclStringType; /* @@ -1557,6 +1558,7 @@ EXTERN int TclMatchFiles _ANSI_ARGS_((Tcl_Interp *interp, char *separators, Tcl_DString *dirPtr, char *pattern, char *tail)); EXTERN int TclNeedSpace _ANSI_ARGS_((char *start, char *end)); +EXTERN Tcl_Obj * TclNewProcBodyObj _ANSI_ARGS_((Proc *procPtr)); EXTERN int TclObjCommandComplete _ANSI_ARGS_((Tcl_Obj *cmdPtr)); EXTERN int TclObjInterpProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, diff --git a/generic/tclObj.c b/generic/tclObj.c index 4e693e8..83a05df 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclObj.c,v 1.2 1998/09/14 18:40:01 stanton Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.3 1998/10/05 22:32:09 escoffon Exp $ */ #include "tclInt.h" @@ -134,6 +134,7 @@ InitTypeTable() Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclByteCodeType); + Tcl_RegisterObjType(&tclProcBodyType); tclEmptyStringRep = (char *) ckalloc((unsigned) 1); tclEmptyStringRep[0] = '\0'; diff --git a/generic/tclProc.c b/generic/tclProc.c index fb55f64..bb6a8e5 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -10,12 +10,34 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.15 1998/09/14 18:40:02 stanton Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.16 1998/10/05 22:32:10 escoffon Exp $ */ #include "tclInt.h" #include "tclCompile.h" +/* + * Prototypes for static functions in this file + */ + +static void ProcBodyDup _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr)); +static void ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr)); +static int ProcBodySetFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static void ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr)); + +/* + * The ProcBodyObjType type + */ + +Tcl_ObjType tclProcBodyType = { + "procbody", /* name for this type */ + ProcBodyFree, /* FreeInternalRep procedure */ + ProcBodyDup, /* DupInternalRep procedure */ + ProcBodyUpdateString, /* UpdateString procedure */ + ProcBodySetFromAny /* SetFromAny procedure */ +}; + /* *---------------------------------------------------------------------- @@ -124,7 +146,7 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) */ procPtr->cmdPtr = (Command *) cmd; - + return TCL_OK; } @@ -135,6 +157,10 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) * TclCreateProc -- * * Creates the data associated with a Tcl procedure definition. + * This procedure knows how to handle two types of body objects: + * strings and procbody. Strings are the traditional (and common) value + * for bodies, procbody are values created by extensions that have + * loaded a previously compiled script. * * Results: * Returns TCL_OK on success, along with a pointer to a Tcl @@ -165,103 +191,141 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) char *args, *bytes, *p; register CompiledLocal *localPtr; Tcl_Obj *defPtr; + int precompiled = 0; + + if (bodyPtr->typePtr == &tclProcBodyType) { + /* + * Because the body is a TclProProcBody, the actual body is already + * compiled, and it is not shared with anyone else, so it's OK not to + * unshare it (as a matter of fact, it is bad to unshare it, because + * there may be no source code). + * + * We don't create and initialize a Proc structure for the procedure; + * rather, we use what is in the body object. Note that + * we initialize its cmdPtr field below after we've created the command + * for the procedure. We increment the ref count of the Proc struct + * since the command (soon to be created) will be holding a reference + * to it. + */ + + procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr; + procPtr->iPtr = iPtr; + procPtr->refCount++; + precompiled = 1; + } else { + /* + * If the procedure's body object is shared because its string value is + * identical to, e.g., the body of another procedure, we must create a + * private copy for this procedure to use. Such sharing of procedure + * bodies is rare but can cause problems. A procedure body is compiled + * in a context that includes the number of compiler-allocated "slots" + * for local variables. Each formal parameter is given a local variable + * slot (the "procPtr->numCompiledLocals = numArgs" assignment + * below). This means that the same code can not be shared by two + * procedures that have a different number of arguments, even if their + * bodies are identical. Note that we don't use Tcl_DuplicateObj since + * we would not want any bytecode internal representation. + */ + + if (Tcl_IsShared(bodyPtr)) { + bytes = Tcl_GetStringFromObj(bodyPtr, &length); + bodyPtr = Tcl_NewStringObj(bytes, length); + } - /* - * If the procedure's body object is shared because its string value is - * identical to, e.g., the body of another procedure, we must create a - * private copy for this procedure to use. Such sharing of procedure - * bodies is rare but can cause problems. A procedure body is compiled - * in a context that includes the number of compiler-allocated "slots" - * for local variables. Each formal parameter is given a local variable - * slot (the "procPtr->numCompiledLocals = numArgs" assignment - * below). This means that the same code can not be shared by two - * procedures that have a different number of arguments, even if their - * bodies are identical. Note that we don't use Tcl_DuplicateObj since - * we would not want any bytecode internal representation. - */ - - if (Tcl_IsShared(bodyPtr)) { - bytes = Tcl_GetStringFromObj(bodyPtr, &length); - bodyPtr = Tcl_NewStringObj(bytes, length); - } - - /* - * Create and initialize a Proc structure for the procedure. Note that - * we initialize its cmdPtr field below after we've created the command - * for the procedure. We increment the ref count of the procedure's - * body object since there will be a reference to it in the Proc - * structure. - */ + /* + * Create and initialize a Proc structure for the procedure. Note that + * we initialize its cmdPtr field below after we've created the command + * for the procedure. We increment the ref count of the procedure's + * body object since there will be a reference to it in the Proc + * structure. + */ - Tcl_IncrRefCount(bodyPtr); - - procPtr = (Proc *) ckalloc(sizeof(Proc)); - procPtr->iPtr = iPtr; - procPtr->refCount = 1; - procPtr->bodyPtr = bodyPtr; - procPtr->numArgs = 0; /* actual argument count is set below. */ - procPtr->numCompiledLocals = 0; - procPtr->firstLocalPtr = NULL; - procPtr->lastLocalPtr = NULL; + Tcl_IncrRefCount(bodyPtr); + + procPtr = (Proc *) ckalloc(sizeof(Proc)); + procPtr->iPtr = iPtr; + procPtr->refCount = 1; + procPtr->bodyPtr = bodyPtr; + procPtr->numArgs = 0; /* actual argument count is set below. */ + procPtr->numCompiledLocals = 0; + procPtr->firstLocalPtr = NULL; + procPtr->lastLocalPtr = NULL; + } /* * Break up the argument list into argument specifiers, then process * each argument specifier. + * If the body is precompiled, processing is limited to checking that + * the the parsed argument is consistent with the one stored in the + * Proc. * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS. */ args = Tcl_GetStringFromObj(argsPtr, &length); result = Tcl_SplitList(interp, args, &numArgs, &argArray); if (result != TCL_OK) { - goto procError; + goto procError; + } + + if (precompiled) { + if (numArgs > procPtr->numArgs) { + char buf[128]; + sprintf(buf, "\": arg list contains %d entries, precompiled header expects %d", + numArgs, procPtr->numArgs); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, + buf, (char *) NULL); + goto procError; + } + localPtr = procPtr->firstLocalPtr; + } else { + procPtr->numArgs = numArgs; + procPtr->numCompiledLocals = numArgs; } - - procPtr->numArgs = numArgs; - procPtr->numCompiledLocals = numArgs; for (i = 0; i < numArgs; i++) { - int fieldCount, nameLength, valueLength; - char **fieldValues; + int fieldCount, nameLength, valueLength; + char **fieldValues; - /* - * Now divide the specifier up into name and default. - */ + /* + * Now divide the specifier up into name and default. + */ - result = Tcl_SplitList(interp, argArray[i], &fieldCount, - &fieldValues); - if (result != TCL_OK) { - goto procError; - } - if (fieldCount > 2) { - ckfree((char *) fieldValues); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "too many fields in argument specifier \"", - argArray[i], "\"", (char *) NULL); - goto procError; - } - if ((fieldCount == 0) || (*fieldValues[0] == 0)) { - ckfree((char *) fieldValues); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "procedure \"", procName, - "\" has argument with no name", (char *) NULL); - goto procError; - } + result = Tcl_SplitList(interp, argArray[i], &fieldCount, + &fieldValues); + if (result != TCL_OK) { + goto procError; + } + if (fieldCount > 2) { + ckfree((char *) fieldValues); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "too many fields in argument specifier \"", + argArray[i], "\"", (char *) NULL); + goto procError; + } + if ((fieldCount == 0) || (*fieldValues[0] == 0)) { + ckfree((char *) fieldValues); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, + "\" has argument with no name", (char *) NULL); + goto procError; + } - nameLength = strlen(fieldValues[0]); - if (fieldCount == 2) { - valueLength = strlen(fieldValues[1]); - } else { - valueLength = 0; - } + nameLength = strlen(fieldValues[0]); + if (fieldCount == 2) { + valueLength = strlen(fieldValues[1]); + } else { + valueLength = 0; + } - /* - * Check that the formal parameter name is a scalar. - */ + /* + * Check that the formal parameter name is a scalar. + */ - p = fieldValues[0]; - while (*p != '\0') { - if (*p == '(') { - char *q = p; - do { + p = fieldValues[0]; + while (*p != '\0') { + if (*p == '(') { + char *q = p; + do { q++; } while (*q != '\0'); q--; @@ -278,36 +342,84 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) p++; } - /* - * Allocate an entry in the runtime procedure frame's array of local - * variables for the argument. - */ + if (precompiled) { + /* + * compare the parsed argument with the stored one + */ + + if ((localPtr->nameLength != nameLength) + || (strcmp(localPtr->name, fieldValues[0])) + || (localPtr->frameIndex != i) + || (localPtr->flags != (VAR_SCALAR | VAR_ARGUMENT)) + || ((localPtr->defValuePtr == NULL) + && (fieldCount == 2)) + || ((localPtr->defValuePtr != NULL) + && (fieldCount != 2))) { + char buf[128]; + sprintf(buf, "\": formal parameter %d is inconsistent with precompiled body", + i); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, + buf, (char *) NULL); + ckfree((char *) fieldValues); + goto procError; + } - localPtr = (CompiledLocal *) ckalloc((unsigned) - (sizeof(CompiledLocal) - sizeof(localPtr->name) - + nameLength+1)); - if (procPtr->firstLocalPtr == NULL) { - procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; - } else { - procPtr->lastLocalPtr->nextPtr = localPtr; - procPtr->lastLocalPtr = localPtr; - } - localPtr->nextPtr = NULL; - localPtr->nameLength = nameLength; - localPtr->frameIndex = i; - localPtr->flags = VAR_SCALAR | VAR_ARGUMENT; - localPtr->resolveInfo = NULL; + /* + * compare the default value if any + */ + + if (localPtr->defValuePtr != NULL) { + int tmpLength; + char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr, + &tmpLength); + if ((valueLength != tmpLength) + || (strncmp(fieldValues[1], tmpPtr, + (size_t) tmpLength))) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, + "\": formal parameter \"", + fieldValues[0], + "\" has default value inconsistent with precompiled body", + (char *) NULL); + ckfree((char *) fieldValues); + goto procError; + } + } + + localPtr = localPtr->nextPtr; + } else { + /* + * Allocate an entry in the runtime procedure frame's array of + * local variables for the argument. + */ + + localPtr = (CompiledLocal *) ckalloc((unsigned) + (sizeof(CompiledLocal) - sizeof(localPtr->name) + + nameLength+1)); + if (procPtr->firstLocalPtr == NULL) { + procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; + } else { + procPtr->lastLocalPtr->nextPtr = localPtr; + procPtr->lastLocalPtr = localPtr; + } + localPtr->nextPtr = NULL; + localPtr->nameLength = nameLength; + localPtr->frameIndex = i; + localPtr->flags = VAR_SCALAR | VAR_ARGUMENT; + localPtr->resolveInfo = NULL; - if (fieldCount == 2) { - localPtr->defValuePtr = + if (fieldCount == 2) { + localPtr->defValuePtr = Tcl_NewStringObj(fieldValues[1], valueLength); - Tcl_IncrRefCount(localPtr->defValuePtr); - } else { - localPtr->defValuePtr = NULL; + Tcl_IncrRefCount(localPtr->defValuePtr); + } else { + localPtr->defValuePtr = NULL; + } + strcpy(localPtr->name, fieldValues[0]); } - strcpy(localPtr->name, fieldValues[0]); - - ckfree((char *) fieldValues); + + ckfree((char *) fieldValues); } /* @@ -322,19 +434,23 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) return TCL_OK; procError: - Tcl_DecrRefCount(bodyPtr); - while (procPtr->firstLocalPtr != NULL) { - localPtr = procPtr->firstLocalPtr; - procPtr->firstLocalPtr = localPtr->nextPtr; + if (precompiled) { + procPtr->refCount--; + } else { + Tcl_DecrRefCount(bodyPtr); + while (procPtr->firstLocalPtr != NULL) { + localPtr = procPtr->firstLocalPtr; + procPtr->firstLocalPtr = localPtr->nextPtr; - defPtr = localPtr->defValuePtr; - if (defPtr != NULL) { - Tcl_DecrRefCount(defPtr); - } + defPtr = localPtr->defValuePtr; + if (defPtr != NULL) { + Tcl_DecrRefCount(defPtr); + } - ckfree((char *) localPtr); + ckfree((char *) localPtr); + } + ckfree((char *) procPtr); } - ckfree((char *) procPtr); if (argArray != NULL) { ckfree((char *) argArray); } @@ -1241,7 +1357,7 @@ TclGetInterpProc() * by a DLL exist. * * Results: - * Returns the internal address of the TclProcInterpProc procedure. + * Returns the internal address of the TclObjInterpProc procedure. * * Side effects: * None. @@ -1254,3 +1370,159 @@ TclGetObjInterpProc() { return TclObjInterpProc; } + +/* + *---------------------------------------------------------------------- + * + * TclNewProcBodyObj -- + * + * Creates a new object, of type "procbody", whose internal + * representation is the given Proc struct. + * The newly created object's reference count is 0. + * + * Results: + * Returns a pointer to a newly allocated Tcl_Obj, 0 on error. + * + * Side effects: + * The reference count in the ByteCode attached to the Proc is bumped up + * by one, since the internal rep stores a pointer to it. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclNewProcBodyObj(procPtr) + Proc *procPtr; /* the Proc struct to store as the internal + * representation. */ +{ + Tcl_Obj *objPtr; + + if (!procPtr) { + return (Tcl_Obj *) NULL; + } + + objPtr = Tcl_NewStringObj("", 0); + + if (objPtr) { + objPtr->typePtr = &tclProcBodyType; + objPtr->internalRep.otherValuePtr = (VOID *) procPtr; + + procPtr->refCount++; + } + + return objPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ProcBodyDup -- + * + * Tcl_ObjType's Dup function for the proc body object. + * Bumps the reference count on the Proc stored in the internal + * representation. + * + * Results: + * None. + * + * Side effects: + * Sets up the object in dupPtr to be a duplicate of the one in srcPtr. + * + *---------------------------------------------------------------------- + */ + +static void ProcBodyDup(srcPtr, dupPtr) + Tcl_Obj *srcPtr; /* object to copy */ + Tcl_Obj *dupPtr; /* target object for the duplication */ +{ + Proc *procPtr = (Proc *) srcPtr->internalRep.otherValuePtr; + + dupPtr->typePtr = &tclProcBodyType; + dupPtr->internalRep.otherValuePtr = (VOID *) procPtr; + procPtr->refCount++; +} + +/* + *---------------------------------------------------------------------- + * + * ProcBodyFree -- + * + * Tcl_ObjType's Free function for the proc body object. + * The reference count on its Proc struct is decreased by 1; if the count + * reaches 0, the proc is freed. + * + * Results: + * None. + * + * Side effects: + * If the reference count on the Proc struct reaches 0, the struct is freed. + * + *---------------------------------------------------------------------- + */ + +static void +ProcBodyFree(objPtr) + Tcl_Obj *objPtr; /* the object to clean up */ +{ + Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr; + procPtr->refCount--; + if (procPtr->refCount <= 0) { + TclProcCleanupProc(procPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * ProcBodySetFromAny -- + * + * Tcl_ObjType's SetFromAny function for the proc body object. + * Calls panic. + * + * Results: + * Theoretically returns a TCL result code. + * + * Side effects: + * Calls panic, since we can't set the value of the object from a string + * representation (or any other internal ones). + * + *---------------------------------------------------------------------- + */ + +static int +ProcBodySetFromAny(interp, objPtr) + Tcl_Interp *interp; /* current interpreter */ + Tcl_Obj *objPtr; /* object pointer */ +{ + panic("called ProcBodySetFromAny"); + + /* + * this to keep compilers happy. + */ + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ProcBodyUpdateString -- + * + * Tcl_ObjType's UpdateString function for the proc body object. + * Calls panic. + * + * Results: + * None. + * + * Side effects: + * Calls panic, since we this type has no string representation. + * + *---------------------------------------------------------------------- + */ + +static void +ProcBodyUpdateString(objPtr) + Tcl_Obj *objPtr; /* the object to update */ +{ + panic("called ProcBodyUpdateString"); +} diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c new file mode 100644 index 0000000..b4e15c2 --- /dev/null +++ b/generic/tclTestProcBodyObj.c @@ -0,0 +1,317 @@ +/* + * tclTestProcBodyObj.c -- + * + * Implements the "procbodytest" package, which contains commands + * to test creation of Tcl procedures whose body argument is a + * Tcl_Obj of type "procbody" rather than a string. + * + * Copyright (c) 1998 by Scriptics Corporation. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclTestProcBodyObj.c,v 1.1 1998/10/05 22:32:10 escoffon Exp $ + */ + +#include "tclInt.h" + +/* + * name and version of this package + */ + +static char packageName[] = "procbodytest"; +static char packageVersion[] = "1.0"; + +/* + * Name of the commands exported by this package + */ + +static char procCommand[] = "proc"; + +/* + * this struct describes an entry in the table of command names and command + * procs + */ + +typedef struct CmdTable +{ + char *cmdName; /* command name */ + Tcl_ObjCmdProc *proc; /* command proc */ + int exportIt; /* if 1, export the command */ +} CmdTable; + +/* + * Declarations for functions defined in this file. + */ + +static int ProcBodyTestProcObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static int ProcBodyTestInitInternal _ANSI_ARGS_((Tcl_Interp *interp, + int isSafe)); +static int RegisterCommand _ANSI_ARGS_((Tcl_Interp* interp, + char *namespace, CONST CmdTable *cmdTablePtr)); + +/* + * List of commands to create when the package is loaded; must go after the + * declarations of the enable command procedure. + */ + +static CONST CmdTable commands[] = +{ + { procCommand, ProcBodyTestProcObjCmd, 1 }, + + { 0, 0, 0 } +}; + +static CONST CmdTable safeCommands[] = +{ + { procCommand, ProcBodyTestProcObjCmd, 1 }, + + { 0, 0, 0 } +}; + +/* + *---------------------------------------------------------------------- + * + * Procbodytest_Init -- + * + * This procedure initializes the "procbodytest" package. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Procbodytest_Init(interp) + Tcl_Interp *interp; /* the Tcl interpreter for which the package + * is initialized */ +{ + return ProcBodyTestInitInternal(interp, 0); +} + +/* + *---------------------------------------------------------------------- + * + * Procbodytest_SafeInit -- + * + * This procedure initializes the "procbodytest" package. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Procbodytest_SafeInit(interp) + Tcl_Interp *interp; /* the Tcl interpreter for which the package + * is initialized */ +{ + return ProcBodyTestInitInternal(interp, 1); +} + +/* + *---------------------------------------------------------------------- + * + * RegisterCommand -- + * + * This procedure registers a command in the context of the given namespace. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int RegisterCommand(interp, namespace, cmdTablePtr) + Tcl_Interp* interp; /* the Tcl interpreter for which the + * operation is performed */ + char *namespace; /* the namespace in which the command + * is registered */ + CONST CmdTable *cmdTablePtr; /* the command to register */ +{ + char buf[128]; + + if (cmdTablePtr->exportIt) { + sprintf(buf, "namespace eval %s { namespace export %s }", + namespace, cmdTablePtr->cmdName); + if (Tcl_Eval(interp, buf) != TCL_OK) + return TCL_ERROR; + } + + sprintf(buf, "%s::%s", namespace, cmdTablePtr->cmdName); + Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ProcBodyTestInitInternal -- + * + * This procedure initializes the Loader package. + * The isSafe flag is 1 if the interpreter is safe, 0 otherwise. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ProcBodyTestInitInternal(interp, isSafe) + Tcl_Interp *interp; /* the Tcl interpreter for which the package + * is initialized */ + int isSafe; /* 1 if this is a safe interpreter */ +{ + CONST CmdTable *cmdTablePtr; + + cmdTablePtr = (isSafe) ? &safeCommands[0] : &commands[0]; + for ( ; cmdTablePtr->cmdName ; cmdTablePtr++) { + if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) { + return TCL_ERROR; + } + } + + return Tcl_PkgProvide(interp, packageName, packageVersion); +} + +/* + *---------------------------------------------------------------------- + * + * ProcBodyTestProcObjCmd -- + * + * Implements the "procbodytest::proc" command. Here is the command + * description: + * procbodytest::proc newName argList bodyName + * Looks up a procedure called $bodyName and, if the procedure exists, + * constructs a Tcl_Obj of type "procbody" and calls Tcl_ProcObjCmd. + * Arguments: + * newName the name of the procedure to be created + * argList the argument list for the procedure + * bodyName the name of an existing procedure from which the + * body is to be copied. + * This command can be used to trigger the branches in Tcl_ProcObjCmd that + * construct a proc from a "procbody", for example: + * proc a {x} {return $x} + * a 123 + * procbodytest::proc b {x} a + * Note the call to "a 123", which is necessary so that the Proc pointer + * for "a" is filled in by the internal compiler; this is a hack. + * + * Results: + * Returns a standard Tcl code. + * + * Side effects: + * A new procedure is created. + * Leaves an error message in the interp's result on error. + * + *---------------------------------------------------------------------- + */ + +static int +ProcBodyTestProcObjCmd (dummy, interp, objc, objv) + ClientData dummy; /* context; not used */ + Tcl_Interp *interp; /* the current interpreter */ + int objc; /* argument count */ + Tcl_Obj *CONST objv[]; /* arguments */ +{ + char *fullName; + Tcl_Command procCmd; + Command *cmdPtr; + Proc *procPtr = (Proc *) NULL; + Tcl_Obj *bodyObjPtr; + Tcl_Obj *myobjv[5]; + int result; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "newName argsList bodyName"); + return TCL_ERROR; + } + + /* + * Find the Command pointer to this procedure + */ + + fullName = Tcl_GetStringFromObj(objv[3], (int *) NULL); + procCmd = Tcl_FindCommand(interp, fullName, (Tcl_Namespace *) NULL, + TCL_LEAVE_ERR_MSG); + if (procCmd == NULL) { + return TCL_ERROR; + } + + cmdPtr = (Command *) procCmd; + + /* + * check that this is a procedure and not a builtin command: + * If a procedure, cmdPtr->objProc is either 0 or TclObjInterpProc, + * and cmdPtr->proc is either 0 or TclProcInterpProc. + * Also, the compile proc should be 0, but we don't check for that. + */ + + if (((cmdPtr->objProc != NULL) + && (cmdPtr->objProc != TclGetObjInterpProc())) + || ((cmdPtr->proc != NULL) + && (cmdPtr->proc != TclGetInterpProc()))) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "command \"", fullName, + "\" is not a Tcl procedure", (char *) NULL); + return TCL_ERROR; + } + + /* + * it is a Tcl procedure: the client data is the Proc structure + */ + + if (cmdPtr->objProc != NULL) { + procPtr = (Proc *) cmdPtr->objClientData; + } else if (cmdPtr->proc != NULL) { + procPtr = (Proc *) cmdPtr->clientData; + } + + if (procPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", fullName, + "\" does not have a Proc struct!", (char *) NULL); + return TCL_ERROR; + } + + /* + * create a new object, initialize our argument vector, call into Tcl + */ + + bodyObjPtr = TclNewProcBodyObj(procPtr); + if (bodyObjPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "failed to create a procbody object for procedure \"", + fullName, "\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_IncrRefCount(bodyObjPtr); + + myobjv[0] = objv[0]; + myobjv[1] = objv[1]; + myobjv[2] = objv[2]; + myobjv[3] = bodyObjPtr; + myobjv[4] = (Tcl_Obj *) NULL; + + result = Tcl_ProcObjCmd((ClientData) NULL, interp, objc, myobjv); + Tcl_DecrRefCount(bodyObjPtr); + + return result; +} diff --git a/tests/proc.test b/tests/proc.test index f470707..478d15f 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: proc.test,v 1.2 1998/09/14 18:40:12 stanton Exp $ +# RCS: @(#) $Id: proc.test,v 1.3 1998/10/05 22:32:11 escoffon Exp $ if {[string compare test [info procs test]] == 1} then {source defs} @@ -161,3 +161,133 @@ catch {eval namespace delete [namespace children :: test_ns_*]} catch {rename p ""} catch {rename {} ""} catch {unset msg} + +if {[catch {package require procbodytest}]} { + puts "This application couldn't load the \"procbodytest\" package, so I" + puts "can't test creation of procs whose bodies have type \"procbody\"." + return +} + +catch {rename p ""} +catch {rename t ""} + +# Note that the test require that procedures whose body is used to create +# procbody objects must be executed before the procbodytest::proc command +# is executed, so that the Proc struct is populated correctly (CompiledLocals +# are added at compile time). + +test proc-4.1 {TclCreateProc, procbody obj} { + catch { + proc p x {return "$x:$x"} + set rv [p P] + procbodytest::proc t x p + lappend rv [t T] + set rv + } result + catch {rename p ""} + catch {rename t ""} + set result +} {P:P T:T} + +test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} { + catch { + proc p x { + set y [string tolower $x] + return "$x:$y" + } + set rv [p P] + procbodytest::proc t x p + lappend rv [t T] + set rv + } result + catch {rename p ""} + catch {rename t ""} + set result +} {P:p T:t} + +test proc-4.3 {TclCreateProc, procbody obj, too many args} { + catch { + proc p x { + set y [string tolower $x] + return "$x:$y" + } + set rv [p P] + procbodytest::proc t {x x1 x2} p + lappend rv [t T] + set rv + } result + catch {rename p ""} + catch {rename t ""} + set result +} {procedure "t": arg list contains 3 entries, precompiled header expects 1} + +test proc-4.4 {TclCreateProc, procbody obj, inconsitent arg name} { + catch { + proc p {x y z} { + set v [join [list $x $y $z]] + set w [string tolower $v] + return "$v:$w" + } + set rv [p P Q R] + procbodytest::proc t {x x1 z} p + lappend rv [t S T U] + set rv + } result + catch {rename p ""} + catch {rename t ""} + set result +} {procedure "t": formal parameter 1 is inconsistent with precompiled body} + +test proc-4.5 {TclCreateProc, procbody obj, inconsitent arg default type} { + catch { + proc p {x y {z Z}} { + set v [join [list $x $y $z]] + set w [string tolower $v] + return "$v:$w" + } + set rv [p P Q R] + procbodytest::proc t {x y z} p + lappend rv [t S T U] + set rv + } result + catch {rename p ""} + catch {rename t ""} + set result +} {procedure "t": formal parameter 2 is inconsistent with precompiled body} + +test proc-4.6 {TclCreateProc, procbody obj, inconsitent arg default type} { + catch { + proc p {x y z} { + set v [join [list $x $y $z]] + set w [string tolower $v] + return "$v:$w" + } + set rv [p P Q R] + procbodytest::proc t {x y {z Z}} p + lappend rv [t S T U] + set rv + } result + catch {rename p ""} + catch {rename t ""} + set result +} {procedure "t": formal parameter 2 is inconsistent with precompiled body} + +test proc-4.7 {TclCreateProc, procbody obj, inconsitent arg default value} { + catch { + proc p {x y {z Z}} { + set v [join [list $x $y $z]] + set w [string tolower $v] + return "$v:$w" + } + set rv [p P Q R] + procbodytest::proc t {x y {z ZZ}} p + lappend rv [t S T U] + set rv + } result + catch {rename p ""} + catch {rename t ""} + set result +} {procedure "t": formal parameter "z" has default value inconsistent with precompiled body} + +catch {rename p ""} +catch {rename t ""} diff --git a/unix/Makefile.in b/unix/Makefile.in index eb8fc92..332eed2 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -5,7 +5,7 @@ # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.11 1998/09/23 20:13:41 suresh Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.12 1998/10/05 22:32:11 escoffon Exp $ # Current Tcl version; used in various names. @@ -224,7 +224,8 @@ ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ TCLSH_OBJS = tclAppInit.o -TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclUnixTest.o +TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ + tclUnixTest.o XTTEST_OBJS = tclTest.o tclTestObj.o tclUnixTest.o tclXtNotify.o \ tclXtTest.o xtTestInit.o @@ -292,6 +293,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclStringObj.c \ $(GENERIC_DIR)/tclTest.c \ $(GENERIC_DIR)/tclTestObj.c \ + $(GENERIC_DIR)/tclTestProcBodyObj.c \ $(GENERIC_DIR)/tclTimer.c \ $(GENERIC_DIR)/tclUtil.c \ $(GENERIC_DIR)/tclVar.c @@ -401,7 +403,7 @@ topDirName: gendate: yacc -l $(GENERIC_DIR)/tclGetDate.y sed -e 's/yy/TclDate/g' -e '/^#include /d' \ - -e 's/SCCSID/RCS: @(#) $Id: Makefile.in,v 1.11 1998/09/23 20:13:41 suresh Exp $' + -e 's/SCCSID/RCS: @(#) $Id: Makefile.in,v 1.12 1998/10/05 22:32:11 escoffon Exp $' -e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \ -e '/TclDatenewstate:/d' -e '/#pragma/d' \ $(GENERIC_DIR)/tclDate.c @@ -743,6 +745,9 @@ tclTest.o: $(GENERIC_DIR)/tclTest.c tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTestObj.c +tclTestProcBodyObj.o: $(GENERIC_DIR)/tclTestProcBodyObj.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTestProcBodyObj.c + tclTimer.o: $(GENERIC_DIR)/tclTimer.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTimer.c diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index e8b2c13..4427f47 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAppInit.c,v 1.2 1998/09/14 18:40:16 stanton Exp $ + * RCS: @(#) $Id: tclAppInit.c,v 1.3 1998/10/05 22:32:12 escoffon Exp $ */ #ifdef TCL_XT_TEST @@ -29,6 +29,8 @@ int *tclDummyMathPtr = (int *) matherr; #ifdef TCL_TEST +EXTERN int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); #endif /* TCL_TEST */ @@ -106,6 +108,11 @@ Tcl_AppInit(interp) if (TclObjTest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } + if (Procbodytest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init, + Procbodytest_SafeInit); #endif /* TCL_TEST */ /* diff --git a/win/makefile.vc b/win/makefile.vc index 6fdb1f4..8039860 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -4,7 +4,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. -# RCS: @(#) $Id: makefile.vc,v 1.16 1998/09/14 18:40:19 stanton Exp $ +# RCS: @(#) $Id: makefile.vc,v 1.17 1998/10/05 22:32:12 escoffon Exp $ # Does not depend on the presence of any environment variables in # order to compile tcl; all needed information is derived from @@ -103,6 +103,7 @@ TCLSHOBJS = \ TCLTESTOBJS = \ $(TMPDIR)\tclTest.obj \ $(TMPDIR)\tclTestObj.obj \ + $(TMPDIR)\tclTestProcBodyObj.obj \ $(TMPDIR)\tclWinTest.obj \ $(TMPDIR)\testMain.obj diff --git a/win/tclAppInit.c b/win/tclAppInit.c index c679039..3c31bb2 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAppInit.c,v 1.2 1998/09/14 18:40:19 stanton Exp $ + * RCS: @(#) $Id: tclAppInit.c,v 1.3 1998/10/05 22:32:12 escoffon Exp $ */ #include "tcl.h" @@ -18,6 +18,8 @@ #include #ifdef TCL_TEST +EXTERN int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); #endif /* TCL_TEST */ @@ -113,6 +115,11 @@ Tcl_AppInit(interp) if (TclObjTest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } + if (Procbodytest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init, + Procbodytest_SafeInit); #endif /* TCL_TEST */ /* -- cgit v0.12