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.

4 files changed, 711 insertions, 119 deletions

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;
+}