Tcl Source Code

Check-in [c87dd5858f]
Login
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 trunk
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | novem
Files: files | file ages | folders
SHA3-256: c87dd5858f58bdfc7bf3ee793c9592f070a82d7206a8d8baff53e71b5076819d
User & Date: dgp 2018-03-30 20:18:20
Context
2018-04-05
13:36
merge trunk check-in: 526ec0f885 user: dgp tags: novem
2018-03-30
20:18
merge trunk check-in: c87dd5858f user: dgp tags: novem
20:08
merge 8.7 check-in: dc1a13eb81 user: dgp tags: trunk
2018-03-24
10:22
Update TZ info to tzdata2018d. check-in: c0a51531fd user: jima tags: novem
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclCmdIL.c.

2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
....
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
Tcl_LrangeObjCmd(
    ClientData notUsed,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    register Tcl_Obj *const objv[])
				/* Argument objects. */
{
    Tcl_Obj **elemPtrs;
    int listLen, first, last, result;

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "list first last");
	return TCL_ERROR;
    }

................................................................................
    }

    result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1,
	    &first);
    if (result != TCL_OK) {
	return result;
    }
    if (first < 0) {
	first = 0;
    }

    result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1,
	    &last);
    if (result != TCL_OK) {
	return result;
    }
    if (last >= listLen) {
	last = listLen - 1;
    }

    if (first > last) {
	/*
	 * Returning an empty list is easy.
	 */

	return TCL_OK;
    }

    result = TclListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
    if (result != TCL_OK) {
	return result;
    }

    if (Tcl_IsShared(objv[1]) ||
	    ((ListRepPtr(objv[1])->refCount > 1))) {
	Tcl_SetObjResult(interp, Tcl_NewListObj(last - first + 1,
		&elemPtrs[first]));
    } else {
	/*
	 * In-place is possible.
	 */

	if (last < (listLen - 1)) {
	    Tcl_ListObjReplace(interp, objv[1], last + 1, listLen - 1 - last,
		    0, NULL);
	}

	/*
	 * This one is not conditioned on (first > 0) in order to preserve the
	 * string-canonizing effect of [lrange 0 end].
	 */

	Tcl_ListObjReplace(interp, objv[1], 0, first, 0, NULL);
	Tcl_SetObjResult(interp, objv[1]);
    }

    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_LrepeatObjCmd --






<







 







<
<
<






<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<







2532
2533
2534
2535
2536
2537
2538

2539
2540
2541
2542
2543
2544
2545
....
2549
2550
2551
2552
2553
2554
2555



2556
2557
2558
2559
2560
2561


2562


































2563


2564
2565
2566
2567
2568
2569
2570
Tcl_LrangeObjCmd(
    ClientData notUsed,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    register Tcl_Obj *const objv[])
				/* Argument objects. */
{

    int listLen, first, last, result;

    if (objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "list first last");
	return TCL_ERROR;
    }

................................................................................
    }

    result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1,
	    &first);
    if (result != TCL_OK) {
	return result;
    }




    result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1,
	    &last);
    if (result != TCL_OK) {
	return result;
    }





































    Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last));


    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_LrepeatObjCmd --

Changes to generic/tclExecute.c.

4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
....
4764
4765
4766
4767
4768
4769
4770
4771



4772
4773
4774
4775
4776
4777
4778
....
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812

4813
4814
4815
4816
4817
4818
4819
	valuePtr = OBJ_AT_TOS;
	fromIdx = TclGetInt4AtPtr(pc+1);
	toIdx = TclGetInt4AtPtr(pc+5);
	TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1),
		TclGetInt4AtPtr(pc+5)));

	/*
	 * Get the contents of the list, making sure that it really is a list
	 * in the process.
	 */

	if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
	    TRACE_ERROR(interp);
	    goto gotError;
	}

	/*
	 * Skip a lot of work if we're about to throw the result away (common
	 * with uses of [lassign]).
................................................................................
	 * Extra safety for legacy bytecodes:
	 */
	if (toIdx == TCL_INDEX_AFTER) {
	    toIdx = TCL_INDEX_END;
	}

	if ((toIdx == TCL_INDEX_BEFORE) || (fromIdx == TCL_INDEX_AFTER)) {
	    goto emptyList;



	}
	toIdx = TclIndexDecode(toIdx, objc - 1);
	if (toIdx < 0) {
	    goto emptyList;
	} else if (toIdx >= objc) {
	    toIdx = objc - 1;
	}
................................................................................
	 * Extra safety for legacy bytecodes:
	 */
	if (fromIdx == TCL_INDEX_BEFORE) {
	    fromIdx = TCL_INDEX_START;
	}

	fromIdx = TclIndexDecode(fromIdx, objc - 1);
	if (fromIdx < 0) {
	    fromIdx = 0;
	}

	if (fromIdx <= toIdx) {
	    /* Construct the subsquence list */
	    /* unshared optimization */
	    if (Tcl_IsShared(valuePtr)) {
		objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx);
	    } else {
		if (toIdx != objc - 1) {
		    Tcl_ListObjReplace(NULL, valuePtr, toIdx + 1, LIST_MAX,
			    0, NULL);
		}
		Tcl_ListObjReplace(NULL, valuePtr, 0, fromIdx, 0, NULL);
		TRACE_APPEND(("%.30s\n", O2S(valuePtr)));
		NEXT_INST_F(9, 0, 0);
	    }
	} else {
	emptyList:
	    TclNewObj(objResultPtr);
	}


	TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
	NEXT_INST_F(9, 1, 1);

    case INST_LIST_IN:
    case INST_LIST_NOT_IN:	/* Basic list containment operators. */
	value2Ptr = OBJ_AT_TOS;






|



|







 







|
>
>
>







 







<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>







4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
....
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
....
4787
4788
4789
4790
4791
4792
4793


4794



















4795
4796
4797
4798
4799
4800
4801
4802
	valuePtr = OBJ_AT_TOS;
	fromIdx = TclGetInt4AtPtr(pc+1);
	toIdx = TclGetInt4AtPtr(pc+5);
	TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1),
		TclGetInt4AtPtr(pc+5)));

	/*
	 * Get the length of the list, making sure that it really is a list
	 * in the process.
	 */

	if (TclListObjLength(interp, valuePtr, &objc) != TCL_OK) {
	    TRACE_ERROR(interp);
	    goto gotError;
	}

	/*
	 * Skip a lot of work if we're about to throw the result away (common
	 * with uses of [lassign]).
................................................................................
	 * Extra safety for legacy bytecodes:
	 */
	if (toIdx == TCL_INDEX_AFTER) {
	    toIdx = TCL_INDEX_END;
	}

	if ((toIdx == TCL_INDEX_BEFORE) || (fromIdx == TCL_INDEX_AFTER)) {
	emptyList:
	    objResultPtr = Tcl_NewObj();
	    TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
	    NEXT_INST_F(9, 1, 1);
	}
	toIdx = TclIndexDecode(toIdx, objc - 1);
	if (toIdx < 0) {
	    goto emptyList;
	} else if (toIdx >= objc) {
	    toIdx = objc - 1;
	}
................................................................................
	 * Extra safety for legacy bytecodes:
	 */
	if (fromIdx == TCL_INDEX_BEFORE) {
	    fromIdx = TCL_INDEX_START;
	}

	fromIdx = TclIndexDecode(fromIdx, objc - 1);






















	objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx);

	TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
	NEXT_INST_F(9, 1, 1);

    case INST_LIST_IN:
    case INST_LIST_NOT_IN:	/* Basic list containment operators. */
	value2Ptr = OBJ_AT_TOS;

Changes to generic/tclInt.h.

2986
2987
2988
2989
2990
2991
2992


2993
2994
2995
2996
2997
2998
2999
			    Tcl_Obj *listPtr, Tcl_Obj *argPtr);
MODULE_SCOPE Tcl_Obj *	TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    int indexCount, Tcl_Obj *const indexArray[]);
/* TIP #280 */
MODULE_SCOPE void	TclListLines(Tcl_Obj *listObj, int line, int n,
			    int *lines, Tcl_Obj *const *elems);
MODULE_SCOPE Tcl_Obj *	TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr);


MODULE_SCOPE Tcl_Obj *	TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    Tcl_Obj *indexPtr, Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Obj *	TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    int indexCount, Tcl_Obj *const indexArray[],
			    Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name,
			    const EnsembleImplMap map[]);






>
>







2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
			    Tcl_Obj *listPtr, Tcl_Obj *argPtr);
MODULE_SCOPE Tcl_Obj *	TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    int indexCount, Tcl_Obj *const indexArray[]);
/* TIP #280 */
MODULE_SCOPE void	TclListLines(Tcl_Obj *listObj, int line, int n,
			    int *lines, Tcl_Obj *const *elems);
MODULE_SCOPE Tcl_Obj *	TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr);
MODULE_SCOPE Tcl_Obj *	TclListObjRange(Tcl_Obj *listPtr, int fromIdx,
			    int toIdx);
MODULE_SCOPE Tcl_Obj *	TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    Tcl_Obj *indexPtr, Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Obj *	TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    int indexCount, Tcl_Obj *const indexArray[],
			    Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name,
			    const EnsembleImplMap map[]);

Changes to generic/tclListObj.c.

379
380
381
382
383
384
385

















































































386
387
388
389
390
391
392
    }

    TclNewObj(copyPtr);
    TclInvalidateStringRep(copyPtr);
    DupListInternalRep(listPtr, copyPtr);
    return copyPtr;
}

















































































 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjGetElements --
 *
 *	Retreive the elements in a list 'Tcl_Obj'.






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







379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
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
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
    }

    TclNewObj(copyPtr);
    TclInvalidateStringRep(copyPtr);
    DupListInternalRep(listPtr, copyPtr);
    return copyPtr;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclListObjRange --
 *
 *	Makes a slice of a list value.
 *      *listPtr must be known to be a valid list.
 *
 * Results:
 *	Returns a pointer to the sliced list.
 *      This may be a new object or the same object if not shared.
 *
 * Side effects:
 *	The possible conversion of the object referenced by listPtr
 *	to a list object.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclListObjRange(
    Tcl_Obj *listPtr,		/* List object to take a range from. */
    int fromIdx,		/* Index of first element to include. */
    int toIdx)			/* Index of last element to include. */
{
    Tcl_Obj **elemPtrs;
    int listLen, i, newLen;
    List *listRepPtr;

    TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs);

    if (fromIdx < 0) {
	fromIdx = 0;
    }
    if (toIdx >= listLen) {
	toIdx = listLen-1;
    }
    if (fromIdx > toIdx) {
	return Tcl_NewObj();
    }

    newLen = toIdx - fromIdx + 1;

    if (Tcl_IsShared(listPtr) ||
	    ((ListRepPtr(listPtr)->refCount > 1))) {
	return Tcl_NewListObj(newLen, &elemPtrs[fromIdx]);
    }

    /*
     * In-place is possible.
     */

    /*
     * Even if nothing below cause any changes, we still want the
     * string-canonizing effect of [lrange 0 end].
     */

    TclInvalidateStringRep(listPtr);

    /*
     * Delete elements that should not be included.
     */

    for (i = 0; i < fromIdx; i++) {
	TclDecrRefCount(elemPtrs[i]);
    }
    for (i = toIdx + 1; i < listLen; i++) {
	TclDecrRefCount(elemPtrs[i]);
    }

    if (fromIdx > 0) {
	memmove(elemPtrs, &elemPtrs[fromIdx],
		(size_t) newLen * sizeof(Tcl_Obj*));
    }

    listRepPtr = ListRepPtr(listPtr);
    listRepPtr->elemCount = newLen;

    return listPtr;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjGetElements --
 *
 *	Retreive the elements in a list 'Tcl_Obj'.

Changes to generic/tclStubInit.c.

161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
...
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
#if defined(TCL_WIDE_INT_IS_LONG)
/* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore
 * we have to make sure that all stub entries on Cygwin64 follow the Win64
 * signature. Tcl 9 must find a better solution, but that cannot be done
 * without introducing a binary incompatibility.
 */
#define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))dbNewLongObj)
static Tcl_Obj *dbNewLongObj(
    int intValue,
    const char *file,
    int line
) {
#ifdef TCL_MEM_DEBUG
    register Tcl_Obj *objPtr;

    TclDbNewObj(objPtr, file, line);
    objPtr->bytes = NULL;

    objPtr->internalRep.wideValue = (long) intValue;
    objPtr->typePtr = &tclIntType;
    return objPtr;
#else
    return Tcl_NewIntObj(intValue);
#endif
}
#define Tcl_GetLongFromObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetIntFromObj
#define Tcl_NewLongObj (Tcl_Obj*(*)(long))Tcl_NewIntObj
#define Tcl_SetLongObj (void(*)(Tcl_Obj*,long))Tcl_SetIntObj
static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){
    long longValue;
    int result = Tcl_ExprLong(interp, expr, &longValue);
    if (result == TCL_OK) {
	    if ((longValue >= -(long)(UINT_MAX))
		    && (longValue <= (long)(UINT_MAX))) {
	    *ptr = (int)longValue;
................................................................................
		    "integer value too large to represent as non-long integer", -1));
	    result = TCL_ERROR;
	}
    }
    return result;
}
#define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj
static int formatInt(char *buffer, int n){
   return TclFormatInt(buffer, (long)n);
}
#define TclFormatInt (int(*)(char *, long))formatInt

#endif

#endif

/*
 * WARNING: The contents of this file is automatically generated by the






<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







<
<
<
<







161
162
163
164
165
166
167






















168
169
170
171
172
173
174
...
193
194
195
196
197
198
199




200
201
202
203
204
205
206
#if defined(TCL_WIDE_INT_IS_LONG)
/* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore
 * we have to make sure that all stub entries on Cygwin64 follow the Win64
 * signature. Tcl 9 must find a better solution, but that cannot be done
 * without introducing a binary incompatibility.
 */






















static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){
    long longValue;
    int result = Tcl_ExprLong(interp, expr, &longValue);
    if (result == TCL_OK) {
	    if ((longValue >= -(long)(UINT_MAX))
		    && (longValue <= (long)(UINT_MAX))) {
	    *ptr = (int)longValue;
................................................................................
		    "integer value too large to represent as non-long integer", -1));
	    result = TCL_ERROR;
	}
    }
    return result;
}
#define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj





#endif

#endif

/*
 * WARNING: The contents of this file is automatically generated by the

Changes to tests/lrange.test.

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
...
104
105
106
107
108
109
110















111






















































































112
113
114
115
116
117
118
} {1 {unmatched open brace in list}}

test lrange-3.1 {Bug 3588366: end-offsets before start} {
    apply {l {
	lrange $l 0 end-5
    }} {1 2 3 4 5}
} {}

test lrange-3.2 {compiled with static indices out of range, negative} {
    list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3]
} [lrepeat 4 {}]
test lrange-3.3 {compiled with calculated indices out of range, negative constant} {
    list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1]
} [lrepeat 4 {}]
test lrange-3.4 {compiled with calculated indices out of range, after end} {
................................................................................
test lrange-3.5 {compiled with calculated indices, start out of range (negative)} {
    list [lrange {a b c} -1 1] [lrange {a b c} -1+0 end-1] [lrange {a b c} -2 1] [lrange {a b c} -2+0 0+1]
} [lrepeat 4 {a b}]
test lrange-3.6 {compiled with calculated indices, end out of range (after end)} {
    list [lrange {a b c} 1 end+1] [lrange {a b c} 1+0 2+1] [lrange {a b c} 1 end+1] [lrange {a b c} end-1 3+1]
} [lrepeat 4 {b c}]
















 






















































































# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:






<







 







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







86
87
88
89
90
91
92

93
94
95
96
97
98
99
...
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
} {1 {unmatched open brace in list}}

test lrange-3.1 {Bug 3588366: end-offsets before start} {
    apply {l {
	lrange $l 0 end-5
    }} {1 2 3 4 5}
} {}

test lrange-3.2 {compiled with static indices out of range, negative} {
    list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3]
} [lrepeat 4 {}]
test lrange-3.3 {compiled with calculated indices out of range, negative constant} {
    list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1]
} [lrepeat 4 {}]
test lrange-3.4 {compiled with calculated indices out of range, after end} {
................................................................................
test lrange-3.5 {compiled with calculated indices, start out of range (negative)} {
    list [lrange {a b c} -1 1] [lrange {a b c} -1+0 end-1] [lrange {a b c} -2 1] [lrange {a b c} -2+0 0+1]
} [lrepeat 4 {a b}]
test lrange-3.6 {compiled with calculated indices, end out of range (after end)} {
    list [lrange {a b c} 1 end+1] [lrange {a b c} 1+0 2+1] [lrange {a b c} 1 end+1] [lrange {a b c} end-1 3+1]
} [lrepeat 4 {b c}]

test lrange-4.1 {lrange pure promise} -body {
    set ll1 [list $tcl_version 2 3 4]
    # Shared
    set ll2 $ll1
    # With string rep
    string length $ll1
    set rep1 [tcl::unsupported::representation $ll1]
    # Get new pure object
    set x [lrange $ll1 0 end]
    set rep2 [tcl::unsupported::representation $x]
    regexp {object pointer at (\S+)} $rep1 -> obj1
    regexp {object pointer at (\S+)} $rep2 -> obj2
    list $rep1 $rep2 [string equal $obj1 $obj2]
    # Check for a new clean object
} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0}

test lrange-4.2 {lrange pure promise} -body {
    set ll1 [list $tcl_version 2 3 4]
    # Shared
    set ll2 $ll1
    # With string rep
    string length $ll1
    set rep1 [tcl::unsupported::representation $ll1]
    # Get new pure object, not compiled
    set x [[string cat l range] $ll1 0 end]
    set rep2 [tcl::unsupported::representation $x]
    regexp {object pointer at (\S+)} $rep1 -> obj1
    regexp {object pointer at (\S+)} $rep2 -> obj2
    list $rep1 $rep2 [string equal $obj1 $obj2]
    # Check for a new clean object
} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0}

test lrange-4.3 {lrange pure promise} -body {
    set ll1 [list $tcl_version 2 3 4]
    # With string rep
    string length $ll1
    set rep1 [tcl::unsupported::representation $ll1]
    # Get pure object, unshared
    set ll2 [lrange $ll1[set ll1 {}] 0 end]
    set rep2 [tcl::unsupported::representation $ll2]
    regexp {object pointer at (\S+)} $rep1 -> obj1
    regexp {object pointer at (\S+)} $rep2 -> obj2
    list $rep1 $rep2 [string equal $obj1 $obj2]
    # Internal optimisations should keep the same object
} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1}

test lrange-4.4 {lrange pure promise} -body {
    set ll1 [list $tcl_version 2 3 4]
    # With string rep
    string length $ll1
    set rep1 [tcl::unsupported::representation $ll1]
    # Get pure object, unshared, not compiled
    set ll2 [[string cat l range] $ll1[set ll1 {}] 0 end]
    set rep2 [tcl::unsupported::representation $ll2]
    regexp {object pointer at (\S+)} $rep1 -> obj1
    regexp {object pointer at (\S+)} $rep2 -> obj2
    list $rep1 $rep2 [string equal $obj1 $obj2]
    # Internal optimisations should keep the same object
} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1}

# Testing for compiled vs non-compiled behaviour, and shared vs non-shared.
# Far too many variations to check with spelt-out tests.
# Note that this *just* checks whether the different versions are the same
# not whether any of them is correct.
apply {{} {
    set lss     {{} {a} {a b c} {a b c d}}
    set idxs    {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2}
    set lrange  lrange

    foreach ls $lss {
	foreach a $idxs {
	    foreach b $idxs {
                # Shared, uncompiled
                set ls2 $ls
                set expected [list [catch {$lrange $ls $a $b} m] $m]
                # Shared, compiled
                set tester [list lrange $ls $a $b]
                set script [list catch $tester m]
                set script "list \[$script\] \$m"
                test lrange-5.[incr n].1 {lrange shared compiled} \
			[list apply [list {} $script]] $expected
                # Unshared, uncompiled
                set tester [string map [list %l [list $ls] %a $a %b $b] {
                    [string cat l range] [lrange %l 0 end] %a %b
                }]
                set script [list catch $tester m]
                set script "list \[$script\] \$m"
                test lrange-5.$n.2 {lrange unshared uncompiled} \
			[list apply [list {} $script]] $expected
                # Unshared, compiled
                set tester [string map [list %l [list $ls] %a $a %b $b] {
                    lrange [lrange %l 0 end] %a %b
                }]
                set script [list catch $tester m]
                set script "list \[$script\] \$m"
                test lrange-5.$n.3 {lrange unshared compiled} \
			[list apply [list {} $script]] $expected
	    }
	}
    }
}}
 
# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to unix/configure.

5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
....
6460
6461
6462
6463
6464
6465
6466
6467
6468
6469
6470
6471
6472
6473
6474
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS="$LDFLAGS -export-dynamic"
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	CYGWIN_*|MINGW32*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD='${CC} -shared'
	    SHLIB_SUFFIX=".dll"
	    DL_OBJS="tclLoadDl.o"
	    PLAT_OBJS='${CYGWIN_OBJS}'
	    PLAT_SRCS='${CYGWIN_SRCS}'
	    DL_LIBS="-ldl"
................................................................................
    # standard manufacturer compiler.

    if test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes; then :

	case $system in
	    AIX-*) ;;
	    BSD/OS*) ;;
	    CYGWIN_*|MINGW32_*) ;;
	    IRIX*) ;;
	    NetBSD-*|FreeBSD-*|OpenBSD-*) ;;
	    Darwin-*) ;;
	    SCO_SV-3.2*) ;;
	    *) SHLIB_CFLAGS="-fPIC" ;;
	esac
fi






|







 







|







5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
....
6460
6461
6462
6463
6464
6465
6466
6467
6468
6469
6470
6471
6472
6473
6474
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS="$LDFLAGS -export-dynamic"
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	CYGWIN_*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD='${CC} -shared'
	    SHLIB_SUFFIX=".dll"
	    DL_OBJS="tclLoadDl.o"
	    PLAT_OBJS='${CYGWIN_OBJS}'
	    PLAT_SRCS='${CYGWIN_SRCS}'
	    DL_LIBS="-ldl"
................................................................................
    # standard manufacturer compiler.

    if test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes; then :

	case $system in
	    AIX-*) ;;
	    BSD/OS*) ;;
	    CYGWIN_*) ;;
	    IRIX*) ;;
	    NetBSD-*|FreeBSD-*|OpenBSD-*) ;;
	    Darwin-*) ;;
	    SCO_SV-3.2*) ;;
	    *) SHLIB_CFLAGS="-fPIC" ;;
	esac
fi

Changes to unix/tcl.m4.

1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
....
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS="$LDFLAGS -export-dynamic"
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	CYGWIN_*|MINGW32*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD='${CC} -shared'
	    SHLIB_SUFFIX=".dll"
	    DL_OBJS="tclLoadDl.o"
	    PLAT_OBJS='${CYGWIN_OBJS}'
	    PLAT_SRCS='${CYGWIN_SRCS}'
	    DL_LIBS="-ldl"
................................................................................
    # libraries to the right flags for gcc, instead of those for the
    # standard manufacturer compiler.

    AS_IF([test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes], [
	case $system in
	    AIX-*) ;;
	    BSD/OS*) ;;
	    CYGWIN_*|MINGW32_*) ;;
	    IRIX*) ;;
	    NetBSD-*|FreeBSD-*|OpenBSD-*) ;;
	    Darwin-*) ;;
	    SCO_SV-3.2*) ;;
	    *) SHLIB_CFLAGS="-fPIC" ;;
	esac])







|







 







|







1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
....
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS="$LDFLAGS -export-dynamic"
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	CYGWIN_*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD='${CC} -shared'
	    SHLIB_SUFFIX=".dll"
	    DL_OBJS="tclLoadDl.o"
	    PLAT_OBJS='${CYGWIN_OBJS}'
	    PLAT_SRCS='${CYGWIN_SRCS}'
	    DL_LIBS="-ldl"
................................................................................
    # libraries to the right flags for gcc, instead of those for the
    # standard manufacturer compiler.

    AS_IF([test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes], [
	case $system in
	    AIX-*) ;;
	    BSD/OS*) ;;
	    CYGWIN_*) ;;
	    IRIX*) ;;
	    NetBSD-*|FreeBSD-*|OpenBSD-*) ;;
	    Darwin-*) ;;
	    SCO_SV-3.2*) ;;
	    *) SHLIB_CFLAGS="-fPIC" ;;
	esac])