summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorescoffon <escoffon>1998-10-05 22:32:09 (GMT)
committerescoffon <escoffon>1998-10-05 22:32:09 (GMT)
commit7a0266fc2a385695a20d43579b3c6951495a3b21 (patch)
treef25db388c40788f11cbe13b90d87726976d7607e
parent96be4fa0ab6cb9a0ef8b91883cb51e120e857cde (diff)
downloadtcl-7a0266fc2a385695a20d43579b3c6951495a3b21.zip
tcl-7a0266fc2a385695a20d43579b3c6951495a3b21.tar.gz
tcl-7a0266fc2a385695a20d43579b3c6951495a3b21.tar.bz2
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.
-rw-r--r--changes16
-rw-r--r--generic/tclInt.h4
-rw-r--r--generic/tclObj.c3
-rw-r--r--generic/tclProc.c506
-rw-r--r--generic/tclTestProcBodyObj.c317
-rw-r--r--tests/proc.test132
-rw-r--r--unix/Makefile.in11
-rw-r--r--unix/tclAppInit.c9
-rw-r--r--win/makefile.vc3
-rw-r--r--win/tclAppInit.c9
10 files changed, 881 insertions, 129 deletions
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 <values.h>/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' \
<y.tab.c >$(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 <locale.h>
#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 */
/*