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.

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 */
 
     /*