Diff
Not logged in

Differences From Artifact [739f27c2eb]:

To Artifact [eb52a3ba8d]:


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/* 
 * tclProc.c --
 *
 *	This file contains routines that implement Tcl procedures,
 *	including the "proc" and "uplevel" commands.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * 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.46.2.4 2004/03/26 22:28:27 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Prototypes for static functions in this file












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/* 
 * tclProc.c --
 *
 *	This file contains routines that implement Tcl procedures,
 *	including the "proc" and "uplevel" commands.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * 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.46.2.5 2004/05/04 17:44:18 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Prototypes for static functions in this file
211
212
213
214
215
216
217
218
219
220
221
222

223
224
225
226
227
228
229
230
231
 *
 * 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
 *	procedure definition in procPtrPtr.  This definition should

 *	be freed by calling TclCleanupProc() when it is no longer
 *	needed.  Returns TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *	If anything goes wrong, this procedure returns an error
 *	message in the interpreter.
 *
 *----------------------------------------------------------------------
 */







|



|
>
|
|







211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
 *
 * 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
 *	procedure definition in procPtrPtr where the cmdPtr field is not
 *      initialised. This definition should be freed by calling
 *      TclCleanupProc() when it is no longer needed.  Returns TCL_ERROR if
 *      anything goes wrong. 
 *
 * Side effects:
 *	If anything goes wrong, this procedure returns an error
 *	message in the interpreter.
 *
 *----------------------------------------------------------------------
 */
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
        /*
         * 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 {







|
<
|
|
<







253
254
255
256
257
258
259
260

261
262

263
264
265
266
267
268
269
        /*
         * 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. 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 {
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302

        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.
         */
    
        Tcl_IncrRefCount(bodyPtr);

        procPtr = (Proc *) ckalloc(sizeof(Proc));
        procPtr->iPtr = iPtr;
        procPtr->refCount = 1;







|
<
|
|
<







283
284
285
286
287
288
289
290

291
292

293
294
295
296
297
298
299

        if (Tcl_IsShared(bodyPtr)) {
            bytes = Tcl_GetStringFromObj(bodyPtr, &length);
            bodyPtr = Tcl_NewStringObj(bytes, length);
        }

        /*
         * Create and initialize a Proc structure 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;
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
                localPtr->defValuePtr = NULL;
            }
            strcpy(localPtr->name, fieldValues[0]);
	}

        ckfree((char *) fieldValues);
    }

    /*
     * Now initialize the new procedure's cmdPtr field. This will be used
     * later when the procedure is called to determine what namespace the
     * procedure will run in. This will be different than the current
     * namespace if the proc was renamed into a different namespace.
     */
    
    *procPtrPtr = procPtr;
    ckfree((char *) argArray);
    return TCL_OK;

procError:
    if (precompiled) {







<
<
<
<
<
<
<







481
482
483
484
485
486
487







488
489
490
491
492
493
494
                localPtr->defValuePtr = NULL;
            }
            strcpy(localPtr->name, fieldValues[0]);
	}

        ckfree((char *) fieldValues);
    }







    
    *procPtrPtr = procPtr;
    ckfree((char *) argArray);
    return TCL_OK;

procError:
    if (precompiled) {
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
    Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
    CallFrame frame;
    register CallFrame *framePtr = &frame;
    register Var *varPtr;
    register CompiledLocal *localPtr;
    char *procName;
    int nameLen, localCt, numArgs, argCt, i, result;
    Tcl_Obj *objResult = Tcl_GetObjResult(interp);

    /*
     * This procedure generates an array "compiledLocals" that holds the
     * storage for local variables. It starts out with stack-allocated space
     * but uses dynamically-allocated storage if needed.
     */








<







895
896
897
898
899
900
901

902
903
904
905
906
907
908
    Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
    CallFrame frame;
    register CallFrame *framePtr = &frame;
    register Var *varPtr;
    register CompiledLocal *localPtr;
    char *procName;
    int nameLen, localCt, numArgs, argCt, i, result;


    /*
     * This procedure generates an array "compiledLocals" that holds the
     * storage for local variables. It starts out with stack-allocated space
     * but uses dynamically-allocated storage if needed.
     */

1032
1033
1034
1035
1036
1037
1038



1039
1040
1041
1042

1043
1044
1045















1046
1047
1048
1049
1050
1051
1052
	} else {
	    goto incorrectArgs;
	}
	varPtr++;
	localPtr = localPtr->nextPtr;
    }
    if (argCt > 0) {



	incorrectArgs:
	/*
	 * Build up equivalent to Tcl_WrongNumArgs message for proc
	 */

	Tcl_ResetResult(interp);
	Tcl_AppendStringsToObj(objResult,
		"wrong # args: should be \"", procName, (char *) NULL);















	localPtr = procPtr->firstLocalPtr;
	for (i = 1;  i <= numArgs;  i++) {
	    if (localPtr->defValuePtr != NULL) {
		Tcl_AppendStringsToObj(objResult,
			" ?", localPtr->name, "?", (char *) NULL);
	    } else {
		Tcl_AppendStringsToObj(objResult,







>
>
>




>

|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
	} else {
	    goto incorrectArgs;
	}
	varPtr++;
	localPtr = localPtr->nextPtr;
    }
    if (argCt > 0) {
	Tcl_Obj *objResult;
	int len, flags;

	incorrectArgs:
	/*
	 * Build up equivalent to Tcl_WrongNumArgs message for proc
	 */

	Tcl_ResetResult(interp);
	objResult = Tcl_GetObjResult(interp);
	Tcl_AppendToObj(objResult, "wrong # args: should be \"", -1);

	/*
	 * Quote the proc name if it contains spaces (Bug 942757).
	 */
	
	len = Tcl_ScanCountedElement(procName, nameLen, &flags);
	if (len != nameLen) {
	    char *procName1 = ckalloc((unsigned) len);
	    len = Tcl_ConvertCountedElement(procName, nameLen, procName1, flags);
	    Tcl_AppendToObj(objResult, procName1, len);
	    ckfree(procName1);
	} else {
	    Tcl_AppendToObj(objResult, procName, len);
	}

	localPtr = procPtr->firstLocalPtr;
	for (i = 1;  i <= numArgs;  i++) {
	    if (localPtr->defValuePtr != NULL) {
		Tcl_AppendStringsToObj(objResult,
			" ?", localPtr->name, "?", (char *) NULL);
	    } else {
		Tcl_AppendStringsToObj(objResult,