Tcl Source Code

Check-in [5ea1084e1e]
Login
Core Home Timeline Branches Tags Tickets Wiki Clone or Download
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:merge 8.5
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | bug-3606683-85
Files: files | file ages | folders
SHA1: 5ea1084e1e71376a93350c314a3ca1410990c3d8
User & Date: dgp 2013-03-06 19:56:31
Context
2013-03-06
20:28
3604074,3606683 Rewrite of the fixempties() routine (and supporting routines) to completely eliminat... check-in: 71a42e2a9c user: dgp tags: core-8-5-branch
19:56
merge 8.5 Closed-Leaf check-in: 5ea1084e1e user: dgp tags: bug-3606683-85
19:53
Rework into Tcl 8.5+ coding style. check-in: 6fd3ededf1 user: dgp tags: bug-3606683-85
12:22
Add Eclipse .project too check-in: 7da71b436d user: jan.nijtmans tags: core-8-5-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Added .fossil-settings/binary-glob. 








>
>
>

1
2
3

*.bmp
*.gif
*.png

Added .fossil-settings/crnl-glob.

Added .fossil-settings/ignore-glob. 
































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

*.a
*.dll
*.exe
*.o
*.obj
*.so
*/Makefile
*/config.cache
*/config.log
*/config.status
*/tclConfig.sh
*/tclsh*
*/tcltest*
unix/dltest.marker
win/tcl.hpj

Added .project. 
























>
>
>
>
>
>
>
>
>
>
>

1
2
3
4
5
6
7
8
9
10
11

<?xml version="1.0" encoding="UTF-8"?>
<projectDescription>
	<name>tcl8.5</name>
	<comment></comment>
	<projects>
	</projects>
	<buildSpec>
	</buildSpec>
	<natures>
	</natures>
</projectDescription>

Added .settings/org.eclipse.core.resources.prefs. 






>
>

1
2

eclipse.preferences.version=1
encoding/<project>=UTF-8

Added .settings/org.eclipse.core.runtime.prefs. 






>
>

1
2

eclipse.preferences.version=1
line.separator=\n

Changes to generic/tclCompile.c. 

413
414
415
416
417
418
419

420
421
422
423
424
425
426
....
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
....
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
....
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266

static void		EnterCmdStartData(CompileEnv *envPtr,
			    int cmdNumber, int srcOffset, int codeOffset);
static void		FreeByteCodeInternalRep(Tcl_Obj *objPtr);
static int		GetCmdLocEncodingSize(CompileEnv *envPtr);
#ifdef TCL_COMPILE_STATS
static void		RecordByteCodeStats(ByteCode *codePtr);
#endif /* TCL_COMPILE_STATS */

static int		SetByteCodeFromAny(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);
static int		FormatInstruction(ByteCode *codePtr,
			    unsigned char *pc, Tcl_Obj *bufferObj);
static void		PrintSourceToObj(Tcl_Obj *appendObj,
			    const char *stringPtr, int maxChars);
/*
................................................................................
{
    return &tclInstructionTable[0];
}
 
/*
 *--------------------------------------------------------------
 *
 * TclRegisterAuxDataType --
 *
 *	This procedure is called to register a new AuxData type in the table
 *	of all AuxData types supported by Tcl.
 *
 * Results:
 *	None.
 *
................................................................................
 *	The type is registered in the AuxData type table. If there was already
 *	a type with the same name as in typePtr, it is replaced with the new
 *	type.
 *
 *--------------------------------------------------------------
 */

void
TclRegisterAuxDataType(
    AuxDataType *typePtr)	/* Information about object type; storage must
				 * be statically allocated (must live forever;
				 * will not be deallocated). */
{
    register Tcl_HashEntry *hPtr;
    int isNew;

................................................................................
    auxDataTypeTableInitialized = 1;
    Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS);

    /*
     * There are only two AuxData type at this time, so register them here.
     */

    TclRegisterAuxDataType(&tclForeachInfoType);
    TclRegisterAuxDataType(&tclJumptableInfoType);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeAuxDataTypeTable --
 *







>







 







|







 







|
|







 







|
|








413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
....
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
....
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
....
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267

static void		EnterCmdStartData(CompileEnv *envPtr,
			    int cmdNumber, int srcOffset, int codeOffset);
static void		FreeByteCodeInternalRep(Tcl_Obj *objPtr);
static int		GetCmdLocEncodingSize(CompileEnv *envPtr);
#ifdef TCL_COMPILE_STATS
static void		RecordByteCodeStats(ByteCode *codePtr);
#endif /* TCL_COMPILE_STATS */
static void		RegisterAuxDataType(AuxDataType *typePtr);
static int		SetByteCodeFromAny(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);
static int		FormatInstruction(ByteCode *codePtr,
			    unsigned char *pc, Tcl_Obj *bufferObj);
static void		PrintSourceToObj(Tcl_Obj *appendObj,
			    const char *stringPtr, int maxChars);
/*
................................................................................
{
    return &tclInstructionTable[0];
}
 
/*
 *--------------------------------------------------------------
 *
 * RegisterAuxDataType --
 *
 *	This procedure is called to register a new AuxData type in the table
 *	of all AuxData types supported by Tcl.
 *
 * Results:
 *	None.
 *
................................................................................
 *	The type is registered in the AuxData type table. If there was already
 *	a type with the same name as in typePtr, it is replaced with the new
 *	type.
 *
 *--------------------------------------------------------------
 */

static void
RegisterAuxDataType(
    AuxDataType *typePtr)	/* Information about object type; storage must
				 * be statically allocated (must live forever;
				 * will not be deallocated). */
{
    register Tcl_HashEntry *hPtr;
    int isNew;

................................................................................
    auxDataTypeTableInitialized = 1;
    Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS);

    /*
     * There are only two AuxData type at this time, so register them here.
     */

    RegisterAuxDataType(&tclForeachInfoType);
    RegisterAuxDataType(&tclJumptableInfoType);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeAuxDataTypeTable --
 *

Changes to generic/tclCompile.h. 

904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
...
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948

			    int catchOnly, ByteCode* codePtr);
MODULE_SCOPE void	TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE int	TclExecuteByteCode(Tcl_Interp *interp,
			    ByteCode *codePtr);
MODULE_SCOPE void	TclFinalizeAuxDataTypeTable(void);
MODULE_SCOPE int	TclFindCompiledLocal(CONST char *name, int nameChars,
			    int create, Proc *procPtr);
MODULE_SCOPE LiteralEntry * TclLookupLiteralEntry(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);
MODULE_SCOPE int	TclFixupForwardJump(CompileEnv *envPtr,
			    JumpFixup *jumpFixupPtr, int jumpDist,
			    int distThreshold);
MODULE_SCOPE void	TclFreeCompileEnv(CompileEnv *envPtr);
MODULE_SCOPE void	TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE void	TclInitAuxDataTypeTable(void);
MODULE_SCOPE void	TclInitByteCodeObj(Tcl_Obj *objPtr,
			    CompileEnv *envPtr);
MODULE_SCOPE void	TclInitCompilation(void);
MODULE_SCOPE void	TclInitCompileEnv(Tcl_Interp *interp,
			    CompileEnv *envPtr, const char *string,
			    int numBytes, CONST CmdFrame* invoker, int word);
MODULE_SCOPE void	TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE void	TclInitLiteralTable(LiteralTable *tablePtr);
#ifdef TCL_COMPILE_STATS
MODULE_SCOPE char *	TclLiteralStats(LiteralTable *tablePtr);
................................................................................
#endif
MODULE_SCOPE int	TclPrintInstruction(ByteCode* codePtr,
			    unsigned char *pc);
MODULE_SCOPE void	TclPrintObject(FILE *outFile,
			    Tcl_Obj *objPtr, int maxChars);
MODULE_SCOPE void	TclPrintSource(FILE *outFile,
			    CONST char *string, int maxChars);
MODULE_SCOPE void	TclRegisterAuxDataType(AuxDataType *typePtr);
MODULE_SCOPE int	TclRegisterLiteral(CompileEnv *envPtr,
			    char *bytes, int length, int flags);
MODULE_SCOPE void	TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr);
MODULE_SCOPE int	TclSingleOpCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	TclSortingOpCmd(ClientData clientData,







<
<








<







 







<








904
905
906
907
908
909
910


911
912
913
914
915
916
917
918

919
920
921
922
923
924
925
...
931
932
933
934
935
936
937

938
939
940
941
942
943
944

			    int catchOnly, ByteCode* codePtr);
MODULE_SCOPE void	TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE int	TclExecuteByteCode(Tcl_Interp *interp,
			    ByteCode *codePtr);
MODULE_SCOPE void	TclFinalizeAuxDataTypeTable(void);
MODULE_SCOPE int	TclFindCompiledLocal(CONST char *name, int nameChars,
			    int create, Proc *procPtr);


MODULE_SCOPE int	TclFixupForwardJump(CompileEnv *envPtr,
			    JumpFixup *jumpFixupPtr, int jumpDist,
			    int distThreshold);
MODULE_SCOPE void	TclFreeCompileEnv(CompileEnv *envPtr);
MODULE_SCOPE void	TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE void	TclInitAuxDataTypeTable(void);
MODULE_SCOPE void	TclInitByteCodeObj(Tcl_Obj *objPtr,
			    CompileEnv *envPtr);

MODULE_SCOPE void	TclInitCompileEnv(Tcl_Interp *interp,
			    CompileEnv *envPtr, const char *string,
			    int numBytes, CONST CmdFrame* invoker, int word);
MODULE_SCOPE void	TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE void	TclInitLiteralTable(LiteralTable *tablePtr);
#ifdef TCL_COMPILE_STATS
MODULE_SCOPE char *	TclLiteralStats(LiteralTable *tablePtr);
................................................................................
#endif
MODULE_SCOPE int	TclPrintInstruction(ByteCode* codePtr,
			    unsigned char *pc);
MODULE_SCOPE void	TclPrintObject(FILE *outFile,
			    Tcl_Obj *objPtr, int maxChars);
MODULE_SCOPE void	TclPrintSource(FILE *outFile,
			    CONST char *string, int maxChars);

MODULE_SCOPE int	TclRegisterLiteral(CompileEnv *envPtr,
			    char *bytes, int length, int flags);
MODULE_SCOPE void	TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr);
MODULE_SCOPE int	TclSingleOpCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]);
MODULE_SCOPE int	TclSortingOpCmd(ClientData clientData,

Changes to generic/tclLiteral.c. 

28
29
30
31
32
33
34




35
36
37
38
39
40
41
...
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
...
403
404
405
406
407
408
409

410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
...
445
446
447
448
449
450
451

452
453
454
455
456
457
458
....
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038

 * Function prototypes for static functions in this file:
 */

static int		AddLocalLiteralEntry(CompileEnv *envPtr,
			    Tcl_Obj *objPtr, int localHash);
static void		ExpandLocalLiteralArray(CompileEnv *envPtr);
static unsigned int	HashString(const char *bytes, int length);




static void		RebuildLiteralTable(LiteralTable *tablePtr);
 
/*
 *----------------------------------------------------------------------
 *
 * TclInitLiteralTable --
 *
................................................................................
	objPtr->bytes = bytes;
	objPtr->length = length;
    } else {
	TclInitStringRep(objPtr, bytes, length);
    }

#ifdef TCL_COMPILE_DEBUG
    if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
	Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be",
		(length>60? 60 : length), bytes);
    }
#endif

    globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry));
    globalPtr->objPtr = objPtr;
................................................................................
		(length>60? 60 : length), bytes, globalPtr->refCount);
    }
    TclVerifyLocalLiteralTable(envPtr);
#endif /*TCL_COMPILE_DEBUG*/
    return objIndex;
}
 

/*
 *----------------------------------------------------------------------
 *
 * TclLookupLiteralEntry --
 *
 *	Finds the LiteralEntry that corresponds to a literal Tcl object
 *	holding a literal.
 *
 * Results:
 *	Returns the matching LiteralEntry if found, otherwise NULL.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

LiteralEntry *
TclLookupLiteralEntry(
    Tcl_Interp *interp,		/* Interpreter for which objPtr was created to
				 * hold a literal. */
    register Tcl_Obj *objPtr)	/* Points to a Tcl object holding a literal
				 * that was previously created by a call to
				 * TclRegisterLiteral. */
{
    Interp *iPtr = (Interp *) interp;
................................................................................
	if (entryPtr->objPtr == objPtr) {
	    return entryPtr;
	}
    }
    return NULL;
}
 

/*
 *----------------------------------------------------------------------
 *
 * TclHideLiteral --
 *
 *	Remove a literal entry from the literal hash tables, leaving it in the
 *	literal array so existing references continue to function. This makes
................................................................................
		localPtr=localPtr->nextPtr) {
	    count++;
	    if (localPtr->refCount != -1) {
		bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
		Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d",
			(length>60? 60 : length), bytes, localPtr->refCount);
	    }
	    if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
		    localPtr->objPtr) == NULL) {
		bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
		Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global",
			(length>60? 60 : length), bytes);
	    }
	    if (localPtr->objPtr->bytes == NULL) {
		Tcl_Panic("TclVerifyLocalLiteralTable: literal has NULL string rep");







>
>
>
>







 







|







 







>



|













|
|







 







>







 







|








28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
...
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
...
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
...
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
....
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044

 * Function prototypes for static functions in this file:
 */

static int		AddLocalLiteralEntry(CompileEnv *envPtr,
			    Tcl_Obj *objPtr, int localHash);
static void		ExpandLocalLiteralArray(CompileEnv *envPtr);
static unsigned int	HashString(const char *bytes, int length);
#ifdef TCL_COMPILE_DEBUG
static LiteralEntry *	LookupLiteralEntry(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);
#endif
static void		RebuildLiteralTable(LiteralTable *tablePtr);
 
/*
 *----------------------------------------------------------------------
 *
 * TclInitLiteralTable --
 *
................................................................................
	objPtr->bytes = bytes;
	objPtr->length = length;
    } else {
	TclInitStringRep(objPtr, bytes, length);
    }

#ifdef TCL_COMPILE_DEBUG
    if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
	Tcl_Panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be",
		(length>60? 60 : length), bytes);
    }
#endif

    globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry));
    globalPtr->objPtr = objPtr;
................................................................................
		(length>60? 60 : length), bytes, globalPtr->refCount);
    }
    TclVerifyLocalLiteralTable(envPtr);
#endif /*TCL_COMPILE_DEBUG*/
    return objIndex;
}
 
#ifdef TCL_COMPILE_DEBUG
/*
 *----------------------------------------------------------------------
 *
 * LookupLiteralEntry --
 *
 *	Finds the LiteralEntry that corresponds to a literal Tcl object
 *	holding a literal.
 *
 * Results:
 *	Returns the matching LiteralEntry if found, otherwise NULL.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static LiteralEntry *
LookupLiteralEntry(
    Tcl_Interp *interp,		/* Interpreter for which objPtr was created to
				 * hold a literal. */
    register Tcl_Obj *objPtr)	/* Points to a Tcl object holding a literal
				 * that was previously created by a call to
				 * TclRegisterLiteral. */
{
    Interp *iPtr = (Interp *) interp;
................................................................................
	if (entryPtr->objPtr == objPtr) {
	    return entryPtr;
	}
    }
    return NULL;
}
 
#endif
/*
 *----------------------------------------------------------------------
 *
 * TclHideLiteral --
 *
 *	Remove a literal entry from the literal hash tables, leaving it in the
 *	literal array so existing references continue to function. This makes
................................................................................
		localPtr=localPtr->nextPtr) {
	    count++;
	    if (localPtr->refCount != -1) {
		bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
		Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d",
			(length>60? 60 : length), bytes, localPtr->refCount);
	    }
	    if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
		    localPtr->objPtr) == NULL) {
		bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
		Tcl_Panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global",
			(length>60? 60 : length), bytes);
	    }
	    if (localPtr->objPtr->bytes == NULL) {
		Tcl_Panic("TclVerifyLocalLiteralTable: literal has NULL string rep");

This page was generated in about 0.037s by Fossil 2.9 [3a8abf492a] 2019-06-12 09:41:26