Check-in [fea67f041d]
Not logged in

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

Overview
Comment:merge with trunk
Timelines: family | ancestors | descendants | both | wtf-8-experiment
Files: files | file ages | folders
SHA1: fea67f041d4341ee6276e7ee59bb388c0a1b67cf
User & Date: chw 2019-07-07 08:26:55
Context
2019-07-08
09:14
merge with trunk check-in: 104960adc4 user: chw tags: wtf-8-experiment
2019-07-07
08:26
merge with trunk check-in: fea67f041d user: chw tags: wtf-8-experiment
08:21
cleanup missing pieces in tbcload and tclcompiler check-in: 7a110bb514 user: chw tags: trunk
2019-07-05
19:47
merge with trunk check-in: 881ffc25d3 user: chw tags: wtf-8-experiment
Changes

Changes to jni/nsf/generic/nsf.c.

24479
24480
24481
24482
24483
24484
24485
24486
24487
24488
24489
24490
24491
24492
24493
24494
24495
24496

24497
24498
24499
24500
24501
24502
24503
       * We expect a non-pos arg. Check whether we a Tcl_Obj already converted
       * to NsfFlagObjType.
       */
      NsfFlag *flagPtr = argumentObj->internalRep.twoPtrValue.ptr1;

#if defined(PARSE_TRACE_FULL)
      fprintf(stderr, "... arg %p %s expect non-pos arg in block %s isFlag %d sig %d serial %d (%d => %d)\n",
              argumentObj, ObjStr(argumentObj), currentParamPtr->name,
              argumentObj->typePtr == &NsfFlagObjType,
              argumentObj->typePtr == &NsfFlagObjType ? flagPtr->signature == paramPtr : 0,
              argumentObj->typePtr == &NsfFlagObjType ? flagPtr->serial == serial : 0,
              argumentObj->typePtr == &NsfFlagObjType ? flagPtr->serial : 0,
              serial );
#endif

      if (argumentObj->typePtr == &NsfFlagObjType
          && flagPtr->signature == paramPtr
          && flagPtr->serial == serial

          ) {
        /*
         * The argument was processed before and the Tcl_Obj is still valid.
         */
        if ((flagPtr->flags & NSF_FLAG_DASHDAH) != 0u) {
          /*
           * We got a dashDash, skip non-pos param definitions and continue with next







|










>







24479
24480
24481
24482
24483
24484
24485
24486
24487
24488
24489
24490
24491
24492
24493
24494
24495
24496
24497
24498
24499
24500
24501
24502
24503
24504
       * We expect a non-pos arg. Check whether we a Tcl_Obj already converted
       * to NsfFlagObjType.
       */
      NsfFlag *flagPtr = argumentObj->internalRep.twoPtrValue.ptr1;

#if defined(PARSE_TRACE_FULL)
      fprintf(stderr, "... arg %p %s expect non-pos arg in block %s isFlag %d sig %d serial %d (%d => %d)\n",
              (void*)argumentObj, ObjStr(argumentObj), currentParamPtr->name,
              argumentObj->typePtr == &NsfFlagObjType,
              argumentObj->typePtr == &NsfFlagObjType ? flagPtr->signature == paramPtr : 0,
              argumentObj->typePtr == &NsfFlagObjType ? flagPtr->serial == serial : 0,
              argumentObj->typePtr == &NsfFlagObjType ? flagPtr->serial : 0,
              serial );
#endif

      if (argumentObj->typePtr == &NsfFlagObjType
          && flagPtr->signature == paramPtr
          && flagPtr->serial == serial
          && flagPtr->paramPtr != NULL /* when the parameter was previously used in a cget */
          ) {
        /*
         * The argument was processed before and the Tcl_Obj is still valid.
         */
        if ((flagPtr->flags & NSF_FLAG_DASHDAH) != 0u) {
          /*
           * We got a dashDash, skip non-pos param definitions and continue with next

Changes to jni/nsf/generic/nsf.h.

213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
  /*fprintf(stderr, "NsfCleanupObject %p %s\n",object,string);*/	\
  NsfCleanupObject_((object))
# define CscFinish(interp,cscPtr,retCode,string)			\
  /*fprintf(stderr, "CscFinish %p %s\n",cscPtr,string);	*/		\
  NSF_DTRACE_METHOD_RETURN_PROBE((cscPtr),(retCode));			\
  CscFinish_((interp), (cscPtr))
#else
# define NDEBUG 1
# define NsfCleanupObject(object,string)				\
  NsfCleanupObject_((object))
# define CscFinish(interp,cscPtr,retCode,string)			\
  NSF_DTRACE_METHOD_RETURN_PROBE(cscPtr,retCode);			\
  CscFinish_((interp), (cscPtr))
#endif








<







213
214
215
216
217
218
219

220
221
222
223
224
225
226
  /*fprintf(stderr, "NsfCleanupObject %p %s\n",object,string);*/	\
  NsfCleanupObject_((object))
# define CscFinish(interp,cscPtr,retCode,string)			\
  /*fprintf(stderr, "CscFinish %p %s\n",cscPtr,string);	*/		\
  NSF_DTRACE_METHOD_RETURN_PROBE((cscPtr),(retCode));			\
  CscFinish_((interp), (cscPtr))
#else

# define NsfCleanupObject(object,string)				\
  NsfCleanupObject_((object))
# define CscFinish(interp,cscPtr,retCode,string)			\
  NSF_DTRACE_METHOD_RETURN_PROBE(cscPtr,retCode);			\
  CscFinish_((interp), (cscPtr))
#endif

Changes to jni/tbcload/cmpInt.h.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
32
33
34
35
36
37
38








39
40
41
42
43
44
45
...
277
278
279
280
281
282
283






284
285
286
287
288
289
290
 *  Internal header file for the Compiler/Loader package.
 *  This header defines a number of macros that are used by both the writer
 *  and reader package to initialize some static variables. We use macros
 *  because the writer and the reader are two separate packages, and we don't
 *  want to share code between the two.
 *
 * Copyright (c) 1998-2000 Ajuba Solutions
 * Copyright (c) 2002      ActiveState SRL
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: cmpInt.h,v 1.6 2002/12/02 17:42:02 andreas_kupries Exp $
 */

................................................................................
 * Activate features specific to 8.5 and higher.
 * JumpTableInfo AuxData (for compiled 'switch').
 */

#if (TCL_MAJOR_VERSION > 8) || ((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 5))
#define TCL_85_PLUS
#endif









/*
 * USE_CATCH_WRAPPER controls whether the emitted code has a catch around
 * the call to loader::bceval and code to strip off the additional back trace
 * from the error info
 */
# define USE_CATCH_WRAPPER 0
................................................................................
/*
 * The one-letter codes for the AuxData types range types
 */
# define CMP_FOREACH_INFO		'F'
#ifdef TCL_85_PLUS
# define CMP_JUMPTABLE_INFO		'J'
#endif







/*
 * the following set of procedures needs to be wrapped around a DLLEXPORT
 * macro setup, because they are exported by the Tbcload DLL
 */

# ifdef BUILD_tbcload







|







 







>
>
>
>
>
>
>
>







 







>
>
>
>
>
>







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
...
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
 *  Internal header file for the Compiler/Loader package.
 *  This header defines a number of macros that are used by both the writer
 *  and reader package to initialize some static variables. We use macros
 *  because the writer and the reader are two separate packages, and we don't
 *  want to share code between the two.
 *
 * Copyright (c) 1998-2000 Ajuba Solutions
 * Copyright (c) 2002-2014, 2017 ActiveState Software Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: cmpInt.h,v 1.6 2002/12/02 17:42:02 andreas_kupries Exp $
 */

................................................................................
 * Activate features specific to 8.5 and higher.
 * JumpTableInfo AuxData (for compiled 'switch').
 */

#if (TCL_MAJOR_VERSION > 8) || ((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 5))
#define TCL_85_PLUS
#endif

#if (TCL_MAJOR_VERSION > 8) || ((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 6))
#define TCL_86_PLUS
#endif

#if (TCL_MAJOR_VERSION > 8) || ((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION > 6)) || ((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION == 6) && (TCL_RELEASE_SERIAL >= 2))
#define TCL_862_PLUS
#endif

/*
 * USE_CATCH_WRAPPER controls whether the emitted code has a catch around
 * the call to loader::bceval and code to strip off the additional back trace
 * from the error info
 */
# define USE_CATCH_WRAPPER 0
................................................................................
/*
 * The one-letter codes for the AuxData types range types
 */
# define CMP_FOREACH_INFO		'F'
#ifdef TCL_85_PLUS
# define CMP_JUMPTABLE_INFO		'J'
#endif
#ifdef TCL_86_PLUS
# define CMP_DICTUPDATE_INFO		'D'
#endif
#ifdef TCL_862_PLUS
# define CMP_FOREACH_INFO_2		'f'
#endif

/*
 * the following set of procedures needs to be wrapped around a DLLEXPORT
 * macro setup, because they are exported by the Tbcload DLL
 */

# ifdef BUILD_tbcload

Changes to jni/tbcload/cmpRead.c.

2
3
4
5
6
7
8

9
10
11
12
13
14
15
...
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344






345
346
347
348
349
350
351
...
428
429
430
431
432
433
434








435
436
437
438
439
440
441
...
808
809
810
811
812
813
814

815
816
817
818



819
820
821
822
823



824
825
826
827
828



829
830
831
832
833
834
835
....
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
....
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
....
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
....
1850
1851
1852
1853
1854
1855
1856














1857
1858
1859
1860
1861
1862
1863
....
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
....
2204
2205
2206
2207
2208
2209
2210












2211
2212
2213
2214
2215
2216
2217
....
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
....
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
....
2535
2536
2537
2538
2539
2540
2541



















































































































































































2542
2543
2544
2545
2546
2547
2548
....
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
 * cmpRead.c --
 *
 *  This file contains the code used by the compiled file script loader to
 *  load a compiled script. The script loader is registered in the Init
 *  procedure of the "Loader" package.
 *
 * Copyright (c) 1998-2000 Ajuba Solutions

 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: cmpRead.c,v 1.11 2002/11/28 16:53:10 andreas_kupries Exp $
 */

................................................................................
/*
 * These Tcl_ObjType pointers are initialized the first time that the package
 * is loaded; we do it this way because the actual object types are not
 * exported by the TCL DLL, and therefore if we use the address of the
 * standard types we get an undefined symbol at link time.
 */

static CONST Tcl_ObjType *cmpTclProProcBodyType = 0;
static CONST Tcl_ObjType *cmpByteCodeType = 0;
static CONST Tcl_ObjType *cmpDoubleType = 0;
static CONST Tcl_ObjType *cmpIntType = 0;

/*
 * Same thing for AuxDataTypes.
 */

static CONST AuxDataType *cmpForeachInfoType = 0;
#ifdef TCL_85_PLUS
static CONST AuxDataType *cmpJumptableInfoType = 0;






#endif

static int didLoadTypes = 0;

/*
 * error message to generate when we run into the end of the buffer and we
 * are expecting more stuff
................................................................................
			ExceptionRange *excArray, int excArraySize));
static int	ExtractForeachInfo _ANSI_ARGS_((Tcl_Interp *interp,
			ExtractionEnv *envPtr, AuxData *auxDataPtr));
#ifdef TCL_85_PLUS
static int	ExtractJumptableInfo _ANSI_ARGS_((Tcl_Interp *interp,
			ExtractionEnv *envPtr, AuxData *auxDataPtr));
#endif








static int	ExtractInteger _ANSI_ARGS_((Tcl_Interp *interp,
			ExtractionEnv *envPtr, int *valuePtr));
static int	ExtractObjArray _ANSI_ARGS_((Tcl_Interp *interp,
			int numLitObjects, ExtractionEnv* envPtr,
			Tcl_Obj **objArray, int objArraySize));
static Tcl_Obj *ExtractObject _ANSI_ARGS_((Tcl_Interp *interp,
			ExtractionEnv *envPtr));
................................................................................
    /*
     * The assignements to p must be kept consistent with the ones in
     * TclInitByteCodeObj, so that the arrays are aligned as expected.
     */

    p += sizeof(ByteCode);
    byteCodePtr->codeStart = p;


    p += TCL_ALIGN(numCodeBytes);
    if (numLitObjects > 0) {
	byteCodePtr->objArrayPtr = (Tcl_Obj **) p;



    }

    p += TCL_ALIGN(objArrayBytes);
    if (numExceptRanges > 0) {
	byteCodePtr->exceptArrayPtr = (ExceptionRange *) p;



    }

    p += TCL_ALIGN(exceptArrayBytes);
    if (numAuxDataItems > 0) {
	byteCodePtr->auxDataArrayPtr = (AuxData *) p;



    }

    p += auxDataArrayBytes;
    byteCodePtr->codeDeltaStart = p;
    p += locMapPtr->codeDeltaSize;
    byteCodePtr->codeLengthStart = p;
    p += locMapPtr->codeLengthSize;
................................................................................
{
    Tcl_Obj *objPtr = NULL;
    char *imagePtr;
    char *imageEnd;
    char *objString;
    char typeCode;
    int objStringLength;
    CONST Tcl_ObjType *objTypePtr = NULL;

    imagePtr = envPtr->curImagePtr;
    imageEnd = envPtr->imageEnd;

    /*
     * skip whitespace, get the typecode
     */
................................................................................
	     * The side effects of this need to be investigated further.
	     */

	    objPtr = Tcl_NewStringObj(noSourceCode, -1);
	    Tcl_IncrRefCount(objPtr);

	    objPtr->internalRep.otherValuePtr = (VOID *) localExEnv.codePtr;
	    objPtr->typePtr = cmpByteCodeType;

	    localExEnv.codePtr->refCount++;

	    /*
	     * skip over the ByteCode representation we just read in
	     */

................................................................................
	    Tcl_AppendResult(interp, "unknown object type \"",
		    errBuf, "\"", (char *) NULL);
	    AppendErrorLocation(interp, envPtr);
	    return NULL;
	}

	if (objTypePtr
		&& (Tcl_ConvertToType(interp, objPtr, objTypePtr) != TCL_OK)) {
	    Tcl_DecrRefCount(objPtr);
	    return NULL;
	}
    }

    return objPtr;
}
................................................................................
	    }
#ifdef TCL_85_PLUS
	} else if (typeCode == CMP_JUMPTABLE_INFO) {
	  int result = ExtractJumptableInfo(interp, envPtr, auxPtr);
	  if (result != TCL_OK) {
	    return result;
	  }














#endif
	} else {
	    char errBuf[2];
	    errBuf[0] = typeCode;
	    errBuf[1] = '\0';
	    Tcl_AppendResult(interp, "unknown aux data type: ",
		    errBuf, (char *) NULL);
................................................................................
     * See the comment above Tcl_NewStringObj in ExtractObjArray.
     */

    objPtr = Tcl_NewStringObj(noSourceCode, -1);
    Tcl_IncrRefCount(objPtr);

    objPtr->internalRep.otherValuePtr = (VOID *) exEnv.codePtr;
    objPtr->typePtr = cmpByteCodeType;
    exEnv.codePtr->refCount++;

    CleanupExtractEnv(&exEnv);

    return objPtr;
}
 
................................................................................
	    panic("InitTypes: failed to find the ForeachInfo AuxData type");
	}
#ifdef TCL_85_PLUS
	cmpJumptableInfoType = TclGetAuxDataType("JumptableInfo");
	if (!cmpJumptableInfoType) {
	    panic("InitTypes: failed to find the JumptableInfo AuxData type");
	}












#endif
	didLoadTypes += 1;
    }
}
 
/*
 *----------------------------------------------------------------------
................................................................................
	}
    }

    /*
     * finally! Assign the ForeachInfo to the AuxData.
     */

    auxDataPtr->type = cmpForeachInfoType;
    auxDataPtr->clientData = (ClientData) infoPtr;

    return TCL_OK;

    errorReturn:

    if (infoPtr) {
................................................................................
    }


    /*
     * finally! Assign the JumptableInfo to the AuxData.
     */

    auxDataPtr->type = cmpJumptableInfoType;
    auxDataPtr->clientData = (ClientData) infoPtr;

    return TCL_OK;

    errorReturn:

    if (infoPtr) {
................................................................................
      }
      Tcl_DeleteHashTable(&infoPtr->hashTable);
      ckfree((char *) infoPtr);
    }

    return result;
}



















































































































































































#endif
 
/*
 *----------------------------------------------------------------------
 *
 * ExtractProcBody --
 *
................................................................................
     * We also bump the reference count on the ByteCode because the object
     * contains a reference to it.
     */

    bodyPtr = Tcl_NewStringObj(noSourceCode, -1);
    Tcl_IncrRefCount(bodyPtr);
    bodyPtr->internalRep.otherValuePtr = (VOID *) codePtr;
    bodyPtr->typePtr = cmpByteCodeType;
    codePtr->refCount++;

    /*
     * allocate the proc struct and start populating it.
     * We initialize the reference count on the Proc to 0 because
     * ProcBodyNewObj will bump it when it creates a TclProProcBody Tcl_Obj.
     */







>







 







|
|
|
|





|

|
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>







 







>




>
>
>





>
>
>





>
>
>







 







|







 







|







 







|







 







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







 







|







 







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







 







|







 







|







 







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







 







|







2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
...
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
...
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
...
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
....
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
....
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
....
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
....
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
....
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
....
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
....
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
....
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
....
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
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
....
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
 * cmpRead.c --
 *
 *  This file contains the code used by the compiled file script loader to
 *  load a compiled script. The script loader is registered in the Init
 *  procedure of the "Loader" package.
 *
 * Copyright (c) 1998-2000 Ajuba Solutions
 * Copyright (c) 2000, 2017 ActiveState Software Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: cmpRead.c,v 1.11 2002/11/28 16:53:10 andreas_kupries Exp $
 */

................................................................................
/*
 * These Tcl_ObjType pointers are initialized the first time that the package
 * is loaded; we do it this way because the actual object types are not
 * exported by the TCL DLL, and therefore if we use the address of the
 * standard types we get an undefined symbol at link time.
 */

static const Tcl_ObjType *cmpTclProProcBodyType = 0;
static const Tcl_ObjType *cmpByteCodeType = 0;
static const Tcl_ObjType *cmpDoubleType = 0;
static const Tcl_ObjType *cmpIntType = 0;

/*
 * Same thing for AuxDataTypes.
 */

static const AuxDataType *cmpForeachInfoType = 0;
#ifdef TCL_85_PLUS
static const AuxDataType *cmpJumptableInfoType = 0;
#endif
#ifdef TCL_86_PLUS
static const AuxDataType *cmpDictUpdateInfoType = 0;
#endif
#ifdef TCL_862_PLUS
static const AuxDataType *cmpNewForeachInfoType = 0;
#endif

static int didLoadTypes = 0;

/*
 * error message to generate when we run into the end of the buffer and we
 * are expecting more stuff
................................................................................
			ExceptionRange *excArray, int excArraySize));
static int	ExtractForeachInfo _ANSI_ARGS_((Tcl_Interp *interp,
			ExtractionEnv *envPtr, AuxData *auxDataPtr));
#ifdef TCL_85_PLUS
static int	ExtractJumptableInfo _ANSI_ARGS_((Tcl_Interp *interp,
			ExtractionEnv *envPtr, AuxData *auxDataPtr));
#endif
#ifdef TCL_86_PLUS
static int	ExtractDictUpdateInfo _ANSI_ARGS_((Tcl_Interp *interp,
			ExtractionEnv *envPtr, AuxData *auxDataPtr));
#endif
#ifdef TCL_862_PLUS
static int	ExtractNewForeachInfo _ANSI_ARGS_((Tcl_Interp *interp,
			ExtractionEnv *envPtr, AuxData *auxDataPtr));
#endif
static int	ExtractInteger _ANSI_ARGS_((Tcl_Interp *interp,
			ExtractionEnv *envPtr, int *valuePtr));
static int	ExtractObjArray _ANSI_ARGS_((Tcl_Interp *interp,
			int numLitObjects, ExtractionEnv* envPtr,
			Tcl_Obj **objArray, int objArraySize));
static Tcl_Obj *ExtractObject _ANSI_ARGS_((Tcl_Interp *interp,
			ExtractionEnv *envPtr));
................................................................................
    /*
     * The assignements to p must be kept consistent with the ones in
     * TclInitByteCodeObj, so that the arrays are aligned as expected.
     */

    p += sizeof(ByteCode);
    byteCodePtr->codeStart = p;
    memset(p, 0, (size_t) numCodeBytes);

    p += TCL_ALIGN(numCodeBytes);
    if (numLitObjects > 0) {
	byteCodePtr->objArrayPtr = (Tcl_Obj **) p;
	memset(p, 0, (size_t) objArrayBytes);
    } else {
	byteCodePtr->objArrayPtr = (Tcl_Obj **) 0;
    }

    p += TCL_ALIGN(objArrayBytes);
    if (numExceptRanges > 0) {
	byteCodePtr->exceptArrayPtr = (ExceptionRange *) p;
	memset(p, 0, (size_t) exceptArrayBytes);
    } else {
	byteCodePtr->exceptArrayPtr = (ExceptionRange *) 0;
    }

    p += TCL_ALIGN(exceptArrayBytes);
    if (numAuxDataItems > 0) {
	byteCodePtr->auxDataArrayPtr = (AuxData *) p;
	memset(p, 0, (size_t) auxDataArrayBytes);
    } else {
	byteCodePtr->auxDataArrayPtr = (AuxData *) 0;
    }

    p += auxDataArrayBytes;
    byteCodePtr->codeDeltaStart = p;
    p += locMapPtr->codeDeltaSize;
    byteCodePtr->codeLengthStart = p;
    p += locMapPtr->codeLengthSize;
................................................................................
{
    Tcl_Obj *objPtr = NULL;
    char *imagePtr;
    char *imageEnd;
    char *objString;
    char typeCode;
    int objStringLength;
    const Tcl_ObjType *objTypePtr = NULL;

    imagePtr = envPtr->curImagePtr;
    imageEnd = envPtr->imageEnd;

    /*
     * skip whitespace, get the typecode
     */
................................................................................
	     * The side effects of this need to be investigated further.
	     */

	    objPtr = Tcl_NewStringObj(noSourceCode, -1);
	    Tcl_IncrRefCount(objPtr);

	    objPtr->internalRep.otherValuePtr = (VOID *) localExEnv.codePtr;
	    objPtr->typePtr = (Tcl_ObjType*) cmpByteCodeType;

	    localExEnv.codePtr->refCount++;

	    /*
	     * skip over the ByteCode representation we just read in
	     */

................................................................................
	    Tcl_AppendResult(interp, "unknown object type \"",
		    errBuf, "\"", (char *) NULL);
	    AppendErrorLocation(interp, envPtr);
	    return NULL;
	}

	if (objTypePtr
	    && (Tcl_ConvertToType(interp, objPtr, (Tcl_ObjType *) objTypePtr) != TCL_OK)) {
	    Tcl_DecrRefCount(objPtr);
	    return NULL;
	}
    }

    return objPtr;
}
................................................................................
	    }
#ifdef TCL_85_PLUS
	} else if (typeCode == CMP_JUMPTABLE_INFO) {
	  int result = ExtractJumptableInfo(interp, envPtr, auxPtr);
	  if (result != TCL_OK) {
	    return result;
	  }
#endif
#ifdef TCL_86_PLUS
	} else if (typeCode == CMP_DICTUPDATE_INFO) {
	  int result = ExtractDictUpdateInfo(interp, envPtr, auxPtr);
	  if (result != TCL_OK) {
	    return result;
	  }
#endif
#ifdef TCL_862_PLUS
	} else if (typeCode == CMP_FOREACH_INFO_2) {
	  int result = ExtractNewForeachInfo(interp, envPtr, auxPtr);
	  if (result != TCL_OK) {
	    return result;
	  }
#endif
	} else {
	    char errBuf[2];
	    errBuf[0] = typeCode;
	    errBuf[1] = '\0';
	    Tcl_AppendResult(interp, "unknown aux data type: ",
		    errBuf, (char *) NULL);
................................................................................
     * See the comment above Tcl_NewStringObj in ExtractObjArray.
     */

    objPtr = Tcl_NewStringObj(noSourceCode, -1);
    Tcl_IncrRefCount(objPtr);

    objPtr->internalRep.otherValuePtr = (VOID *) exEnv.codePtr;
    objPtr->typePtr = (Tcl_ObjType *) cmpByteCodeType;
    exEnv.codePtr->refCount++;

    CleanupExtractEnv(&exEnv);

    return objPtr;
}
 
................................................................................
	    panic("InitTypes: failed to find the ForeachInfo AuxData type");
	}
#ifdef TCL_85_PLUS
	cmpJumptableInfoType = TclGetAuxDataType("JumptableInfo");
	if (!cmpJumptableInfoType) {
	    panic("InitTypes: failed to find the JumptableInfo AuxData type");
	}
#endif
#ifdef TCL_86_PLUS
	cmpDictUpdateInfoType = TclGetAuxDataType("DictUpdateInfo");
	if (!cmpDictUpdateInfoType) {
	    panic("InitTypes: failed to find the DictUpdateInfo AuxData type");
	}
#endif
#ifdef TCL_862_PLUS
        cmpNewForeachInfoType = TclGetAuxDataType("NewForeachInfo");
        if (!cmpNewForeachInfoType) {
            panic("InitTypes: failed to find the NewForeachInfo AuxData type");
        }
#endif
	didLoadTypes += 1;
    }
}
 
/*
 *----------------------------------------------------------------------
................................................................................
	}
    }

    /*
     * finally! Assign the ForeachInfo to the AuxData.
     */

    auxDataPtr->type = (AuxDataType *) cmpForeachInfoType;
    auxDataPtr->clientData = (ClientData) infoPtr;

    return TCL_OK;

    errorReturn:

    if (infoPtr) {
................................................................................
    }


    /*
     * finally! Assign the JumptableInfo to the AuxData.
     */

    auxDataPtr->type = (AuxDataType *) cmpJumptableInfoType;
    auxDataPtr->clientData = (ClientData) infoPtr;

    return TCL_OK;

    errorReturn:

    if (infoPtr) {
................................................................................
      }
      Tcl_DeleteHashTable(&infoPtr->hashTable);
      ckfree((char *) infoPtr);
    }

    return result;
}
#endif
 
#ifdef TCL_86_PLUS
/*
 *----------------------------------------------------------------------
 *
 * ExtractDictUpdateInfo --
 *
 *  Extract a DictUpdateInfo struct from the extraction environment..
 *
 * Results:
 *  Returns a TCL error code.
 *
 * Side effects:
 *  Creates a DictUpdateInfo AuxData at *auxPtr.
 *  Sets the TCL result on error.
 *
 *----------------------------------------------------------------------
 */

static int
ExtractDictUpdateInfo(interp, envPtr, auxDataPtr)
    Tcl_Interp *interp;		/* the current interpreter */
    ExtractionEnv *envPtr;	/* the extraction environment */
    AuxData *auxDataPtr;	/* pointer to the AuxData item to be filled
				 * with the DictUpdateInfo extracted from the
				 * image */
{
    int i, numVar, result, value;
    DictUpdateInfo *infoPtr = NULL;

    /*
     * read in the control variables, allocate and initialize the
     * DictUpdateInfo struct.
     */

    result = ExtractInteger(interp, envPtr, &numVar);
    if (result != TCL_OK) {
	return result;
    }

    infoPtr = (DictUpdateInfo *) ckalloc((unsigned)(sizeof(DictUpdateInfo)+numVar*sizeof(int)));
    infoPtr->length = numVar;

    for(i=0; i < numVar;i++) {
        result = ExtractInteger(interp, envPtr, &value);
	if (result != TCL_OK) {
	    goto errorReturn;
	}
	infoPtr->varIndices [i] = value;
    }

    /*
     * finally! Assign the DictUpdateInfo to the AuxData.
     */

    auxDataPtr->type = (AuxDataType *) cmpDictUpdateInfoType;
    auxDataPtr->clientData = (ClientData) infoPtr;

    return TCL_OK;

 errorReturn:

    if (infoPtr) {
	ckfree((char *) infoPtr);
    }

    return result;
}
#endif
 
#ifdef TCL_862_PLUS
/*
 *----------------------------------------------------------------------
 *
 * ExtractNewForeachInfo --
 *
 *  Extract a ForeachInfo struct from the extraction environment..
 *  For the new foreach bytecodes.
 *
 * Results:
 *  Returns a TCL error code.
 *
 * Side effects:
 *  Creates a ForeachInfo AuxData at *auxPtr.
 *  Sets the TCL result on error.
 *
 *----------------------------------------------------------------------
 */

static int
ExtractNewForeachInfo(interp, envPtr, auxDataPtr)
    Tcl_Interp *interp;		/* the current interpreter */
    ExtractionEnv *envPtr;	/* the extraction environment */
    AuxData *auxDataPtr;	/* pointer to the AuxData item to be filled
				 * with the ForeachInfo extracted from the
				 * image */
{
    int i, j, result;
    int numLists, loopCtTemp, numVars;
    ForeachInfo *infoPtr = NULL;
    ForeachVarList *varListPtr = NULL;
    int *varPtr;

    /*
     * read in the control variables, allocate and initialize the
     * ForeachInfo struct.
     */

    result = ExtractInteger(interp, envPtr, &numLists);
    if (result != TCL_OK) {
	return result;
    }

    /*
     * The new bytecodes handling foreach do not use firstValueTemp.
     * Was dropped from saved bytecode. Fake a nice value, see %% below.
     */

    result = ExtractInteger(interp, envPtr, &loopCtTemp);
    if (result != TCL_OK) {
	return result;
    }

    infoPtr = (ForeachInfo *) ckalloc((unsigned)
	    (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
    infoPtr->numLists = numLists;
    infoPtr->firstValueTemp = 0; /* %% */
    infoPtr->loopCtTemp = loopCtTemp;
    for (i=0 ; i < numLists ; i++) {
	infoPtr->varLists[i] = (ForeachVarList *) NULL;
    }

    /*
     * now load the ForeachVarList structs
     */

    for (i=0 ; i < numLists ; i++) {
	result = ExtractInteger(interp, envPtr, &numVars);
	if (result != TCL_OK) {
	    goto errorReturn;
	}

	varListPtr = (ForeachVarList *) ckalloc((unsigned)
		sizeof(ForeachVarList) + numVars*sizeof(int));
	infoPtr->varLists[i] = varListPtr;
	varListPtr->numVars = numVars;

	varPtr = &varListPtr->varIndexes[0];
	for (j=0 ; j < numVars ; j++) {
	    result = ExtractInteger(interp, envPtr, varPtr);
	    if (result != TCL_OK) {
		goto errorReturn;
	    }
	    varPtr++;
	}
    }

    /*
     * finally! Assign the ForeachInfo to the AuxData.
     */

    auxDataPtr->type = (AuxDataType *) cmpForeachInfoType;
    auxDataPtr->clientData = (ClientData) infoPtr;

    return TCL_OK;

    errorReturn:

    if (infoPtr) {
	for (i=0 ; i < infoPtr->numLists ; i++) {
	    ckfree((char *) infoPtr->varLists[i]);
	}
	ckfree((char *) infoPtr);
    }

    return result;
}
 
#endif
 
/*
 *----------------------------------------------------------------------
 *
 * ExtractProcBody --
 *
................................................................................
     * We also bump the reference count on the ByteCode because the object
     * contains a reference to it.
     */

    bodyPtr = Tcl_NewStringObj(noSourceCode, -1);
    Tcl_IncrRefCount(bodyPtr);
    bodyPtr->internalRep.otherValuePtr = (VOID *) codePtr;
    bodyPtr->typePtr = (Tcl_ObjType *) cmpByteCodeType;
    codePtr->refCount++;

    /*
     * allocate the proc struct and start populating it.
     * We initialize the reference count on the Proc to 0 because
     * ProcBodyNewObj will bump it when it creates a TclProProcBody Tcl_Obj.
     */

Changes to jni/tclkit/vqtcl/library/mkclvfs.tcl.

1
2
3
4
5
6
7
8
9
..
12
13
14
15
16
17
18

19
20
21
22
23
24
25
26
27
28
29
30











31

32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
..
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
...
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
...
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
# mkclvfs.tcl -- Metakit Compatibility Layer Virtual File System driver
# Rewritten from mk4vfs.tcl, orig by Matt Newman and Jean-Claude Wippler 

# 1.0 initial release
# 1.1 view size renamed to count
# 1.2 replace view calls by vget (simpler and faster)
# 1.3 modified to use the vlerq extension i.s.o. thrive
# 1.4 minor cleanup
# 1.5 adjusted for vlerq 4
................................................................................

package require vfs
package require vlerq

namespace eval ::vfs::mkcl {
    interp alias {} ::vfs::mkcl::vopen {} ::vlerq open
    interp alias {} ::vfs::mkcl::vget {} ::vlerq get

        
    namespace eval v {
        variable seq 0  ;# used to generate a unique db handle
        variable rootv  ;# maps handle to the "dirs" root view
        variable dname  ;# maps handle to cached list of directory names
        variable prows  ;# maps handle to cached list of parent row numbers
    }

# public

    proc Mount {mkfile local args} {
        set db mkclvfs[incr v::seq]











        set v::rootv($db) [vget [vopen $mkfile] 0 dirs]

        set v::dname($db) [vget $v::rootv($db) * name]
        set v::prows($db) [vget $v::rootv($db) * parent]
        #parray v::dname
        #parray v::prows
        ::vfs::filesystem mount $local [list ::vfs::mkcl::handler $db]
        ::vfs::RegisterMount $local [list ::vfs::mkcl::Unmount $db]
        return $db
    }
    
    proc Unmount {db local} {
        ::vfs::filesystem unmount $local
        unset v::rootv($db) v::dname($db) v::prows($db)
    }
    
# private

    proc handler {db cmd root path actual args} {
        #puts [list MKCL $db <$cmd> r: $root p: $path a: $actual $args]
        switch $cmd {
            matchindirectory { eval [linsert $args 0 $cmd $db $path $actual] }
            fileattributes   { eval [linsert $args 0 $cmd $db $root $path] } 
            default          { eval [linsert $args 0 $cmd $db $path] }
        }
    }
    
    proc fail {code} {
        ::vfs::filesystem posixerror $::vfs::posix($code)
    }
    
    proc lookUp {db path} {
        set dirs $v::rootv($db)
        set parent 0
        set elems [file split $path]
        set remain [llength $elems]
        foreach e $elems {
            set r ""
................................................................................
                }
                fail ENOENT
            }
        }
        # evaluating this 4-item result returns the files subview
        list vget $dirs $parent files
    }
    
    proc isDir {tag} {
        expr {[llength $tag] == 4}
    }
    
    if {$::tcl_version eq "8.4"} {
            proc apply {cmd args} { eval [concat $cmd $args] }
    } else {
            proc apply {cmd args} { {*}$cmd {*}$args }
    }
    
# methods

    proc matchindirectory {db path actual pattern type} {
        set o {}
        if {$type == 0} { set type 20 }
        if {[catch {set tag [lookUp $db $path]} err]} { return {} }
        if {$pattern ne ""} {
................................................................................
                }
            }
        } elseif {$type & ([isDir $tag]?4:16)} {
            set o [list $actual]
        }
        return $o
    }
    
    proc fileattributes {db root path args} {
        switch -- [llength $args] {
            0 { return [::vfs::listAttributes] }
            1 { set index [lindex $args 0]
                    return [::vfs::attributesGet $root $path $index] }
            2 { fail EROFS }
        }
    }
    
    proc open {db file mode permissions} {
        if {$mode ne "" && $mode ne "r"} { fail EROFS }
        set tag [lookUp $db $file]
        if {[isDir $tag]} { fail ENOENT }
        foreach {name size date contents} [apply $tag *] break
        if {[string length $contents] != $size} {
            set contents [::vfs::zip -mode decompress $contents]
................................................................................
        set fd [::vfs::memchan]
        fconfigure $fd -translation binary
        puts -nonewline $fd $contents
        fconfigure $fd -translation auto -encoding [encoding system]
        seek $fd 0
        list $fd
    }
    
    proc access {db path mode} {
        if {$mode & 2} { fail EROFS }
        lookUp $db $path
    }
    
    proc stat {db path} {
        set tag [lookUp $db $path]
        set l 1
        if {[isDir $tag]} {
            set t directory
            set s 0
            set d 0

|







 







>
|











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








|




|






|



|



|







 







|



|





|







 







|








|







 







|




|







1
2
3
4
5
6
7
8
9
..
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
..
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
...
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
...
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
# mkclvfs.tcl -- Metakit Compatibility Layer Virtual File System driver
# Rewritten from mk4vfs.tcl, orig by Matt Newman and Jean-Claude Wippler

# 1.0 initial release
# 1.1 view size renamed to count
# 1.2 replace view calls by vget (simpler and faster)
# 1.3 modified to use the vlerq extension i.s.o. thrive
# 1.4 minor cleanup
# 1.5 adjusted for vlerq 4
................................................................................

package require vfs
package require vlerq

namespace eval ::vfs::mkcl {
    interp alias {} ::vfs::mkcl::vopen {} ::vlerq open
    interp alias {} ::vfs::mkcl::vget {} ::vlerq get
    interp alias {} ::vfs::mkcl::vload {} ::vlerq load

    namespace eval v {
        variable seq 0  ;# used to generate a unique db handle
        variable rootv  ;# maps handle to the "dirs" root view
        variable dname  ;# maps handle to cached list of directory names
        variable prows  ;# maps handle to cached list of parent row numbers
    }

# public

    proc Mount {mkfile local args} {
        set db mkclvfs[incr v::seq]
        set done 0
        if {![catch {::file system $mkfile} fs] && ($fs ne "native")} {
            if {![catch {::open $mkfile rb} f]} {
                if {![catch {::read $f} data]} {
                    ::close $f
                    set v::rootv($db) [vget [vload $data] 0 dirs]
                    set done 1
                }
            }
        }
        if {!$done} {
            set v::rootv($db) [vget [vopen $mkfile] 0 dirs]
        }
        set v::dname($db) [vget $v::rootv($db) * name]
        set v::prows($db) [vget $v::rootv($db) * parent]
        #parray v::dname
        #parray v::prows
        ::vfs::filesystem mount $local [list ::vfs::mkcl::handler $db]
        ::vfs::RegisterMount $local [list ::vfs::mkcl::Unmount $db]
        return $db
    }

    proc Unmount {db local} {
        ::vfs::filesystem unmount $local
        unset v::rootv($db) v::dname($db) v::prows($db)
    }

# private

    proc handler {db cmd root path actual args} {
        #puts [list MKCL $db <$cmd> r: $root p: $path a: $actual $args]
        switch $cmd {
            matchindirectory { eval [linsert $args 0 $cmd $db $path $actual] }
            fileattributes   { eval [linsert $args 0 $cmd $db $root $path] }
            default          { eval [linsert $args 0 $cmd $db $path] }
        }
    }

    proc fail {code} {
        ::vfs::filesystem posixerror $::vfs::posix($code)
    }

    proc lookUp {db path} {
        set dirs $v::rootv($db)
        set parent 0
        set elems [file split $path]
        set remain [llength $elems]
        foreach e $elems {
            set r ""
................................................................................
                }
                fail ENOENT
            }
        }
        # evaluating this 4-item result returns the files subview
        list vget $dirs $parent files
    }

    proc isDir {tag} {
        expr {[llength $tag] == 4}
    }

    if {$::tcl_version eq "8.4"} {
            proc apply {cmd args} { eval [concat $cmd $args] }
    } else {
            proc apply {cmd args} { {*}$cmd {*}$args }
    }

# methods

    proc matchindirectory {db path actual pattern type} {
        set o {}
        if {$type == 0} { set type 20 }
        if {[catch {set tag [lookUp $db $path]} err]} { return {} }
        if {$pattern ne ""} {
................................................................................
                }
            }
        } elseif {$type & ([isDir $tag]?4:16)} {
            set o [list $actual]
        }
        return $o
    }

    proc fileattributes {db root path args} {
        switch -- [llength $args] {
            0 { return [::vfs::listAttributes] }
            1 { set index [lindex $args 0]
                    return [::vfs::attributesGet $root $path $index] }
            2 { fail EROFS }
        }
    }

    proc open {db file mode permissions} {
        if {$mode ne "" && $mode ne "r"} { fail EROFS }
        set tag [lookUp $db $file]
        if {[isDir $tag]} { fail ENOENT }
        foreach {name size date contents} [apply $tag *] break
        if {[string length $contents] != $size} {
            set contents [::vfs::zip -mode decompress $contents]
................................................................................
        set fd [::vfs::memchan]
        fconfigure $fd -translation binary
        puts -nonewline $fd $contents
        fconfigure $fd -translation auto -encoding [encoding system]
        seek $fd 0
        list $fd
    }

    proc access {db path mode} {
        if {$mode & 2} { fail EROFS }
        lookUp $db $path
    }

    proc stat {db path} {
        set tag [lookUp $db $path]
        set l 1
        if {[isDir $tag]} {
            set t directory
            set s 0
            set d 0

Changes to jni/tkpath/library/tkpath.tcl.

24
25
26
27
28
29
30
31
32
33
34
35
36



37
38
39
40
41
42
43
..
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78



79
80
81
82
83
84
85
..
89
90
91
92
93
94
95
96
97
98
99



100
101
102
103
104
105
106
107
108



109
110
111
112
113
114
115
...
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
	namespace export *
	namespace ensemble create
    }
}

# ::tkp::matrix::rotate --
# Arguments:
#	angle	Angle in grad
#	cx	X-center coordinate
#	cy	Y-center coordinate
# Results:
#       The transformation matrix.
proc ::tkp::matrix::rotate {angle {cx 0} {cy 0}} {



    set myCos [expr {cos($angle)}]
    set mySin [expr {sin($angle)}]
    if {$cx == 0 && $cy == 0} {
	return [list [list $myCos $mySin] [list [expr {-1.*$mySin}] $myCos] {0 0}]
    }
    return [list [list $myCos $mySin] [list [expr {-1.*$mySin}] $myCos] \
	[list [expr {$cx - $myCos*$cx + $mySin*$cy}] \
................................................................................
proc ::tkp::matrix::flip {{cx 0} {cy 0} {fx 1} {fy 1}} {
    return [list [list $fx 0] [list 0 $fy] \
	[list [expr {$cx*(1-$fx)}] [expr {$cy*($fy-1)}]]]
}

# ::tkp::matrix::rotateflip --
# Arguments:
#	angle	Angle in grad
#	cx	X-center coordinate
#	cy	Y-center coordinate
#	fx	1 no flip, -1 horizontal flip
#	fy	1 no flip, -1 vertical flip
# Results:
#       The transformation matrix.
proc ::tkp::matrix::rotateflip {{angle 0} {cx 0} {cy 0} {fx 1} {fy 1}} {



    set myCos [expr {cos($angle)}]
    set mySin [expr {sin($angle)}]
    if {$cx == 0 && $cy == 0} {
	return [list [list [expr {$fx*$myCos}] [expr {$fx*$mySin}]] \
	    [list [expr {-1.*$mySin*$fy}] [expr {$myCos*$fy}]] {0 0}]
    }
    return [list [list [expr {$fx*$myCos}] [expr {$fx*$mySin}]] \
................................................................................
        [expr {$mySin*$cx*(1.-$fx) + $myCos*$cy*($fy-1.) + $cy - $mySin*$cx - $myCos*$cy}] \
	]]

}

# ::tkp::matrix::skewx --
# Arguments:
#	angle	Angle in grad
# Results:
#       The transformation matrix.
proc ::tkp::matrix::skewx {angle} {



    return [list {1 0} [list [expr {tan($angle)}] 1] {0 0}]
}

# ::tkp::matrix::skewy --
# Arguments:
#	angle	Angle in grad
# Results:
#       The transformation matrix.
proc ::tkp::matrix::skewy {angle} {



    return [list [list 1 [expr {tan($angle)}]] {0 1} {0 0}]
}

# ::tkp::matrix::move --
# Arguments:
#	dx	Difference in x direction
#	dy	Difference in y direction
................................................................................
    expr {$a * 57.29577951308232}
}

# ::tkp::path::cg::xyad2p
# Arguments:
#	cx	center x coordinate
#	cy	center y coordinate
#	a	angle in radians
#	d ...	distances
# Results:
#	Return points at given distances on a ray from center x,y to angle a.
proc ::tkp::path::cg::xyad2p {cx cy a d args} {



    lmap d [concat $d $args] {
	list [expr {$cx + $d * cos($a)}] [expr {$cy - $d * sin($a)}]
    }
}

# ::tkp::path::cg::xyra2p
# Arguments:
#	cx	center x coordinate
#	cy	center y coordinate
#	r	radius
#	a	angle in radians
# Results:
#	Return points forming angle a on a circle with radius r.
proc ::tkp::path::cg::xyra2p {cx cy r a args} {



    lmap a [concat $a $args] {
	list [expr {$cx + $r * cos($a)}] [expr {$cy - $r * sin($a)}]
    }
}

# ::tkp::path::ellipse --
# Arguments:







|





>
>
>







 







|







>
>
>







 







|



>
>
>





|



>
>
>







 







|




>
>
>










|



>
>
>







24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
..
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
..
95
96
97
98
99
100
101
102
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
...
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
	namespace export *
	namespace ensemble create
    }
}

# ::tkp::matrix::rotate --
# Arguments:
#	angle	Angle in radians or degrees (with "d" suffix)
#	cx	X-center coordinate
#	cy	Y-center coordinate
# Results:
#       The transformation matrix.
proc ::tkp::matrix::rotate {angle {cx 0} {cy 0}} {
    if {[string match "*d" $angle]} {
	set angle [expr {[string range $angle 0 end-1] / 45.0 * atan(1)}]
    }
    set myCos [expr {cos($angle)}]
    set mySin [expr {sin($angle)}]
    if {$cx == 0 && $cy == 0} {
	return [list [list $myCos $mySin] [list [expr {-1.*$mySin}] $myCos] {0 0}]
    }
    return [list [list $myCos $mySin] [list [expr {-1.*$mySin}] $myCos] \
	[list [expr {$cx - $myCos*$cx + $mySin*$cy}] \
................................................................................
proc ::tkp::matrix::flip {{cx 0} {cy 0} {fx 1} {fy 1}} {
    return [list [list $fx 0] [list 0 $fy] \
	[list [expr {$cx*(1-$fx)}] [expr {$cy*($fy-1)}]]]
}

# ::tkp::matrix::rotateflip --
# Arguments:
#	angle	Angle in radians or degrees (with "d" suffix)
#	cx	X-center coordinate
#	cy	Y-center coordinate
#	fx	1 no flip, -1 horizontal flip
#	fy	1 no flip, -1 vertical flip
# Results:
#       The transformation matrix.
proc ::tkp::matrix::rotateflip {{angle 0} {cx 0} {cy 0} {fx 1} {fy 1}} {
    if {[string match "*d" $angle]} {
	set angle [expr {[string range $angle 0 end-1] / 45.0 * atan(1)}]
    }
    set myCos [expr {cos($angle)}]
    set mySin [expr {sin($angle)}]
    if {$cx == 0 && $cy == 0} {
	return [list [list [expr {$fx*$myCos}] [expr {$fx*$mySin}]] \
	    [list [expr {-1.*$mySin*$fy}] [expr {$myCos*$fy}]] {0 0}]
    }
    return [list [list [expr {$fx*$myCos}] [expr {$fx*$mySin}]] \
................................................................................
        [expr {$mySin*$cx*(1.-$fx) + $myCos*$cy*($fy-1.) + $cy - $mySin*$cx - $myCos*$cy}] \
	]]

}

# ::tkp::matrix::skewx --
# Arguments:
#	angle	Angle in radians or degrees (with "d" suffix)
# Results:
#       The transformation matrix.
proc ::tkp::matrix::skewx {angle} {
    if {[string match "*d" $angle]} {
	set angle [expr {[string range $angle 0 end-1] / 45.0 * atan(1)}]
    }
    return [list {1 0} [list [expr {tan($angle)}] 1] {0 0}]
}

# ::tkp::matrix::skewy --
# Arguments:
#	angle	Angle in radians or degrees (with "d" suffix)
# Results:
#       The transformation matrix.
proc ::tkp::matrix::skewy {angle} {
    if {[string match "*d" $angle]} {
	set angle [expr {[string range $angle 0 end-1] / 45.0 * atan(1)}]
    }
    return [list [list 1 [expr {tan($angle)}]] {0 1} {0 0}]
}

# ::tkp::matrix::move --
# Arguments:
#	dx	Difference in x direction
#	dy	Difference in y direction
................................................................................
    expr {$a * 57.29577951308232}
}

# ::tkp::path::cg::xyad2p
# Arguments:
#	cx	center x coordinate
#	cy	center y coordinate
#	a	angle in radians or degrees (with "d" suffix)
#	d ...	distances
# Results:
#	Return points at given distances on a ray from center x,y to angle a.
proc ::tkp::path::cg::xyad2p {cx cy a d args} {
    if {[string match "*d" $a]} {
	set a [expr {[string range $a 0 end-1] / 45.0 * atan(1)}]
    }
    lmap d [concat $d $args] {
	list [expr {$cx + $d * cos($a)}] [expr {$cy - $d * sin($a)}]
    }
}

# ::tkp::path::cg::xyra2p
# Arguments:
#	cx	center x coordinate
#	cy	center y coordinate
#	r	radius
#	a	angle in radians or degrees (with "d" suffix)
# Results:
#	Return points forming angle a on a circle with radius r.
proc ::tkp::path::cg::xyra2p {cx cy r a args} {
    if {[string match "*d" $a]} {
	set a [expr {[string range $a 0 end-1] / 45.0 * atan(1)}]
    }
    lmap a [concat $a $args] {
	list [expr {$cx + $r * cos($a)}] [expr {$cy - $r * sin($a)}]
    }
}

# ::tkp::path::ellipse --
# Arguments:

Changes to undroid/tclcompiler/cmpInt.h.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
32
33
34
35
36
37
38








39
40
41
42
43
44
45
...
277
278
279
280
281
282
283






284
285
286
287
288
289
290
 *  Internal header file for the Compiler/Loader package.
 *  This header defines a number of macros that are used by both the writer
 *  and reader package to initialize some static variables. We use macros
 *  because the writer and the reader are two separate packages, and we don't
 *  want to share code between the two.
 *
 * Copyright (c) 1998-2000 Ajuba Solutions
 * Copyright (c) 2002      ActiveState SRL
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: cmpInt.h,v 1.6 2002/12/02 17:42:02 andreas_kupries Exp $
 */

................................................................................
 * Activate features specific to 8.5 and higher.
 * JumpTableInfo AuxData (for compiled 'switch').
 */

#if (TCL_MAJOR_VERSION > 8) || ((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 5))
#define TCL_85_PLUS
#endif









/*
 * USE_CATCH_WRAPPER controls whether the emitted code has a catch around
 * the call to loader::bceval and code to strip off the additional back trace
 * from the error info
 */
# define USE_CATCH_WRAPPER 0
................................................................................
/*
 * The one-letter codes for the AuxData types range types
 */
# define CMP_FOREACH_INFO		'F'
#ifdef TCL_85_PLUS
# define CMP_JUMPTABLE_INFO		'J'
#endif







/*
 * the following set of procedures needs to be wrapped around a DLLEXPORT
 * macro setup, because they are exported by the Tbcload DLL
 */

# ifdef BUILD_tbcload







|







 







>
>
>
>
>
>
>
>







 







>
>
>
>
>
>







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
...
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
 *  Internal header file for the Compiler/Loader package.
 *  This header defines a number of macros that are used by both the writer
 *  and reader package to initialize some static variables. We use macros
 *  because the writer and the reader are two separate packages, and we don't
 *  want to share code between the two.
 *
 * Copyright (c) 1998-2000 Ajuba Solutions
 * Copyright (c) 2002-2014, 2017 ActiveState Software Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: cmpInt.h,v 1.6 2002/12/02 17:42:02 andreas_kupries Exp $
 */

................................................................................
 * Activate features specific to 8.5 and higher.
 * JumpTableInfo AuxData (for compiled 'switch').
 */

#if (TCL_MAJOR_VERSION > 8) || ((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 5))
#define TCL_85_PLUS
#endif

#if (TCL_MAJOR_VERSION > 8) || ((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 6))
#define TCL_86_PLUS
#endif

#if (TCL_MAJOR_VERSION > 8) || ((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION > 6)) || ((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION == 6) && (TCL_RELEASE_SERIAL >= 2))
#define TCL_862_PLUS
#endif

/*
 * USE_CATCH_WRAPPER controls whether the emitted code has a catch around
 * the call to loader::bceval and code to strip off the additional back trace
 * from the error info
 */
# define USE_CATCH_WRAPPER 0
................................................................................
/*
 * The one-letter codes for the AuxData types range types
 */
# define CMP_FOREACH_INFO		'F'
#ifdef TCL_85_PLUS
# define CMP_JUMPTABLE_INFO		'J'
#endif
#ifdef TCL_86_PLUS
# define CMP_DICTUPDATE_INFO		'D'
#endif
#ifdef TCL_862_PLUS
# define CMP_FOREACH_INFO_2		'f'
#endif

/*
 * the following set of procedures needs to be wrapped around a DLLEXPORT
 * macro setup, because they are exported by the Tbcload DLL
 */

# ifdef BUILD_tbcload

Changes to undroid/tclcompiler/cmpWrite.c.

631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
....
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
....
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
....
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573

4574
4575
4576

4577
4578
4579
4580
4581
4582
4583
    Interp *iPtr = (Interp *) interp;
    Tcl_DString inBuffer, outBuffer;
    char *nativeInName;
    char *nativeOutName;
    Tcl_Channel chan;
    int result;
    struct stat statBuf;
	unsigned short fileMode;
    Tcl_Obj *cmdObjPtr;
    LiteralTable glt; /* Save buffer for global literals */

    Tcl_ResetResult(interp);

    Tcl_DStringInit(&inBuffer);
    Tcl_DStringInit(&outBuffer);
................................................................................
            if (numChars > 50) {
                numChars = 50;
                ellipsis = "...";
            }
            sprintf(buf, "\n    (compiling body of proc \"%.*s%s\", line %d)",
                    numChars, fullName, ellipsis, ERRORLINE(interp));
            Tcl_AddObjErrorInfo(interp, buf, -1);
	    }
        goto cleanAndReturn;
    }

    ctxPtr->numCompiledBodies += 1;

    /*
     * Now that we have compiled the procedure, create a new TCL object
................................................................................
A85EncodeBytes(interp, bytesPtr, numBytes, ctxPtr)
    Tcl_Interp *interp;		/* the current interpreter */
    unsigned char *bytesPtr;	/* the 4-byte sequence to encode */
    int numBytes;		/* how many bytes to encode. If < 4, this
                                 * is the last set in the run. */
    A85EncodeContext *ctxPtr;	/* the encoding context */
{
    long int word = 0;
    int i;
    char toEmit[5];

    for (i=numBytes ; i < 4 ; i++) {
        bytesPtr[i] = 0;
    }

................................................................................
    for (i=3 ; i >= 0 ; i--) {
        word <<= 8;
        word |= bytesPtr[i];
    }

    if (word == 0) {
        A85EmitChar(interp, 'z', ctxPtr);
    }  else {
        int tmp = 0;

        if (word < 0) {
            /* Because some don't support unsigned long */
            tmp = 32;
            word = word - (long)(85L * 85 * 85 * 85 * 32);
        }
        if (word < 0) {
            tmp = 64;
            word = word - (long)(85L * 85 * 85 * 85 * 32);
        }

        /*
         * we emit from least significant to most significant char, so that
         * the 0 chars from an incomplete 4-tuple are the last ones in the
         * sequence and can be omitted (for the last 4-tuple in the array)
         */

        toEmit[4] = EN((word / (long)(85L * 85 * 85 * 85)) + tmp);
        word %= (long)(85L * 85 * 85 * 85);
        toEmit[3] = EN(word / (85L * 85 * 85));
        word %= (85L * 85 * 85);
        toEmit[2] = EN(word / (85L * 85));
        word %= (85L * 85);

        toEmit[1] = EN(word / 85);
        word %= 85;
        toEmit[0] = EN(word);


        /*
         * Emit only 'numBytes+1' chars, since the extra ones are all '!'
         * and can therefore be reconstructed by the decoder (if we know the
         * number of bytes that were encoded).
         */








|







 







|







 







|







 







|
<

<
<
<
<
<
<
<
<
<
<

|

|


<
<
<
<
<
<
>
|
|
<
>







631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
....
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
....
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
....
4542
4543
4544
4545
4546
4547
4548
4549

4550










4551
4552
4553
4554
4555
4556






4557
4558
4559

4560
4561
4562
4563
4564
4565
4566
4567
    Interp *iPtr = (Interp *) interp;
    Tcl_DString inBuffer, outBuffer;
    char *nativeInName;
    char *nativeOutName;
    Tcl_Channel chan;
    int result;
    struct stat statBuf;
    unsigned short fileMode;
    Tcl_Obj *cmdObjPtr;
    LiteralTable glt; /* Save buffer for global literals */

    Tcl_ResetResult(interp);

    Tcl_DStringInit(&inBuffer);
    Tcl_DStringInit(&outBuffer);
................................................................................
            if (numChars > 50) {
                numChars = 50;
                ellipsis = "...";
            }
            sprintf(buf, "\n    (compiling body of proc \"%.*s%s\", line %d)",
                    numChars, fullName, ellipsis, ERRORLINE(interp));
            Tcl_AddObjErrorInfo(interp, buf, -1);
        }
        goto cleanAndReturn;
    }

    ctxPtr->numCompiledBodies += 1;

    /*
     * Now that we have compiled the procedure, create a new TCL object
................................................................................
A85EncodeBytes(interp, bytesPtr, numBytes, ctxPtr)
    Tcl_Interp *interp;		/* the current interpreter */
    unsigned char *bytesPtr;	/* the 4-byte sequence to encode */
    int numBytes;		/* how many bytes to encode. If < 4, this
                                 * is the last set in the run. */
    A85EncodeContext *ctxPtr;	/* the encoding context */
{
    unsigned long word = 0;
    int i;
    char toEmit[5];

    for (i=numBytes ; i < 4 ; i++) {
        bytesPtr[i] = 0;
    }

................................................................................
    for (i=3 ; i >= 0 ; i--) {
        word <<= 8;
        word |= bytesPtr[i];
    }

    if (word == 0) {
        A85EmitChar(interp, 'z', ctxPtr);
    } else {












        /*
         * We emit from least significant to most significant char, so that
         * the 0 chars from an incomplete 4-tuple are the last ones in the
         * sequence and can be omitted (for the last 4-tuple in the array).
         */







        for (i=0 ; i < 5 ; i++) {
            toEmit[i] = EN(word % 85UL);
            word /= 85UL;

        }

        /*
         * Emit only 'numBytes+1' chars, since the extra ones are all '!'
         * and can therefore be reconstructed by the decoder (if we know the
         * number of bytes that were encoded).
         */

Changes to undroid/tsb/examples/northwind.tsb.

1
2
3
4
5
6
7
8
9
10
11
12
1 {h2 "Northwind Sample With SQLite3"} 2 {#HTML
<p>Some helper code to fetch data from an URL ...</p>} 3 {if {![catch {package require TclCurl}]} {
    proc fetch_url {url} {
        set handle [curl::init]
        $handle configure -url $url -bodyvar result
        catch {$handle perform} code
        if {$code != 0} {
            return -code error [curl::easystrerror $code]
        }
        $handle cleanup
        return $result
    }




|







1
2
3
4
5
6
7
8
9
10
11
12
1 {h2 "Northwind Sample With SQLite3"} 2 {#HTML
<p>Some helper code to fetch data from an URL ...</p>} 3 {if {![catch {package require TclCurl}]} {
    proc fetch_url {url} {
        set handle [curl::init]
        $handle configure -url $url -bodyvar result -sslverifypeer 0
        catch {$handle perform} code
        if {$code != 0} {
            return -code error [curl::easystrerror $code]
        }
        $handle cleanup
        return $result
    }