Fossil SCM

Fix the build for FOSSIL_ENABLE_TCL and Tcl9. No idea if this works. Does anybody actually use the FOSSIL_ENABLE_TCL compile-time option?

drh 2025-04-21 15:16 trunk
Commit d93344ec3887514a98dcf4c87155f955053fd74527d3ac3fea3660226ea438d2
Parent 9e035ee3b3a2e47…
1 file changed +16 -78
~ src/th_tcl.c
M src/th_tcl.c
+16 -78
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -183,11 +183,11 @@
183183
 ** the only Tcl API functions that MUST be called prior to being able to call
184184
 ** Tcl_InitStubs (i.e. because it requires a Tcl interpreter). For complete
185185
 ** cleanup if the Tcl stubs initialization fails somehow, the Tcl_DeleteInterp
186186
 ** and Tcl_Finalize function types are also required.
187187
 */
188
-typedef void (tcl_FindExecutableProc) (const char *);
188
+typedef const char *(tcl_FindExecutableProc) (const char *);
189189
 typedef Tcl_Interp *(tcl_CreateInterpProc) (void);
190190
 typedef void (tcl_DeleteInterpProc) (Tcl_Interp *);
191191
 typedef void (tcl_FinalizeProc) (void);
192192
193193
 /*
@@ -321,27 +321,10 @@
321321
 ** by the caller. This must be declared here because quite a few functions in
322322
 ** this file need to use it before it can be defined.
323323
 */
324324
 static int createTclInterp(Th_Interp *interp, void *pContext);
325325
326
-/*
327
-** Returns the TH1 return code corresponding to the specified Tcl
328
-** return code.
329
-*/
330
-static int getTh1ReturnCode(
331
- int rc /* The Tcl return code value to convert. */
332
-){
333
- switch( rc ){
334
- case /*0*/ TCL_OK: return /*0*/ TH_OK;
335
- case /*1*/ TCL_ERROR: return /*1*/ TH_ERROR;
336
- case /*2*/ TCL_RETURN: return /*3*/ TH_RETURN;
337
- case /*3*/ TCL_BREAK: return /*2*/ TH_BREAK;
338
- case /*4*/ TCL_CONTINUE: return /*4*/ TH_CONTINUE;
339
- default /*?*/: return /*?*/ rc;
340
- }
341
-}
342
-
343326
 /*
344327
 ** Returns the Tcl return code corresponding to the specified TH1
345328
 ** return code.
346329
 */
347330
 static int getTclReturnCode(
@@ -387,10 +370,12 @@
387370
 static char *getTclResult(
388371
 Tcl_Interp *pInterp,
389372
 int *pN
390373
 ){
391374
 Tcl_Obj *resultPtr;
375
+ Tcl_Size n;
376
+ char *zRes;
392377
393378
 if( !pInterp ){ /* This should not happen. */
394379
 if( pN ) *pN = 0;
395380
 return 0;
396381
 }
@@ -397,11 +382,13 @@
397382
 resultPtr = Tcl_GetObjResult(pInterp);
398383
 if( !resultPtr ){ /* This should not happen either? */
399384
 if( pN ) *pN = 0;
400385
 return 0;
401386
 }
402
- return Tcl_GetStringFromObj(resultPtr, pN);
387
+ zRes = Tcl_GetStringFromObj(resultPtr, &n);
388
+ *pN = (int)n;
389
+ return zRes;
403390
 }
404391
405392
 /*
406393
 ** Tcl context information used by TH1. This structure definition has been
407394
 ** copied from and should be kept in sync with the one in "main.c".
@@ -416,48 +403,12 @@
416403
 tcl_FinalizeProc *xFinalize; /* Tcl_Finalize() pointer. */
417404
 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
418405
 int useObjProc; /* Non-zero if an objProc can be called directly. */
419406
 int useTip285; /* Non-zero if TIP #285 is available. */
420407
 const char *setup; /* The optional Tcl setup script. */
421
- tcl_NotifyProc *xPreEval; /* Optional, called before Tcl_Eval*(). */
422
- void *pPreContext; /* Optional, provided to xPreEval(). */
423
- tcl_NotifyProc *xPostEval; /* Optional, called after Tcl_Eval*(). */
424
- void *pPostContext; /* Optional, provided to xPostEval(). */
425408
 };
426409
427
-/*
428
-** This function calls the configured xPreEval or xPostEval functions, if any.
429
-** May have arbitrary side-effects. This function returns the result of the
430
-** called notification function or the value of the rc argument if there is no
431
-** notification function configured.
432
-*/
433
-static int notifyPreOrPostEval(
434
- int bIsPost,
435
- Th_Interp *interp,
436
- void *ctx,
437
- int argc,
438
- const char **argv,
439
- int *argl,
440
- int rc
441
-){
442
- struct TclContext *tclContext = (struct TclContext *)ctx;
443
- tcl_NotifyProc *xNotifyProc;
444
-
445
- if( !tclContext ){
446
- Th_ErrorMessage(interp,
447
- "invalid Tcl context", (const char *)"", 0);
448
- return TH_ERROR;
449
- }
450
- xNotifyProc = bIsPost ? tclContext->xPostEval : tclContext->xPreEval;
451
- if( xNotifyProc ){
452
- rc = xNotifyProc(bIsPost ?
453
- tclContext->pPostContext : tclContext->pPreContext,
454
- interp, ctx, argc, argv, TH1_LEN(argl), rc);
455
- }
456
- return rc;
457
-}
458
-
459410
 /*
460411
 ** TH1 command: tclEval arg ?arg ...?
461412
 **
462413
 ** Evaluates the Tcl script and returns its result verbatim. If a Tcl script
463414
 ** error is generated, it will be transformed into a TH1 script error. The
@@ -485,14 +436,10 @@
485436
 tclInterp = GET_CTX_TCL_INTERP(ctx);
486437
 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
487438
 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
488439
 return TH_ERROR;
489440
 }
490
- rc = notifyPreOrPostEval(0, interp, ctx, argc, argv, TH1_LEN(argl), rc);
491
- if( rc!=TH_OK ){
492
- return rc;
493
- }
494441
 Tcl_Preserve((ClientData)tclInterp);
495442
 if( argc==2 ){
496443
 objPtr = Tcl_NewStringObj(argv[1], TH1_LEN(argl[1]));
497444
 Tcl_IncrRefCount(objPtr);
498445
 rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
@@ -507,12 +454,10 @@
507454
 FREE_ARGV_TO_OBJV();
508455
 }
509456
 zResult = getTclResult(tclInterp, &nResult);
510457
 Th_SetResult(interp, zResult, nResult);
511458
 Tcl_Release((ClientData)tclInterp);
512
- rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, TH1_LEN(argl),
513
- getTh1ReturnCode(rc));
514459
 return rc;
515460
 }
516461
517462
 /*
518463
 ** TH1 command: tclExpr arg ?arg ...?
@@ -545,14 +490,10 @@
545490
 tclInterp = GET_CTX_TCL_INTERP(ctx);
546491
 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
547492
 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
548493
 return TH_ERROR;
549494
 }
550
- rc = notifyPreOrPostEval(0, interp, ctx, argc, argv, TH1_LEN(argl), rc);
551
- if( rc!=TH_OK ){
552
- return rc;
553
- }
554495
 Tcl_Preserve((ClientData)tclInterp);
555496
 if( argc==2 ){
556497
 objPtr = Tcl_NewStringObj(argv[1], TH1_LEN(argl[1]));
557498
 Tcl_IncrRefCount(objPtr);
558499
 rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
@@ -565,21 +506,21 @@
565506
 rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
566507
 Tcl_DecrRefCount(objPtr); objPtr = 0;
567508
 FREE_ARGV_TO_OBJV();
568509
 }
569510
 if( rc==TCL_OK ){
570
- zResult = Tcl_GetStringFromObj(resultObjPtr, &nResult);
511
+ Tcl_Size szResult = 0;
512
+ zResult = Tcl_GetStringFromObj(resultObjPtr, &szResult);
513
+ nResult = (int)szResult;
571514
 }else{
572515
 zResult = getTclResult(tclInterp, &nResult);
573516
 }
574
- Th_SetResult(interp, zResult, nResult);
517
+ Th_SetResult(interp, zResult, (int)nResult);
575518
 if( rc==TCL_OK ){
576519
 Tcl_DecrRefCount(resultObjPtr); resultObjPtr = 0;
577520
 }
578521
 Tcl_Release((ClientData)tclInterp);
579
- rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, TH1_LEN(argl),
580
- getTh1ReturnCode(rc));
581522
 return rc;
582523
 }
583524
584525
 /*
585526
 ** TH1 command: tclInvoke command ?arg ...?
@@ -610,14 +551,10 @@
610551
 tclInterp = GET_CTX_TCL_INTERP(ctx);
611552
 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
612553
 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
613554
 return TH_ERROR;
614555
 }
615
- rc = notifyPreOrPostEval(0, interp, ctx, argc, argv, TH1_LEN(argl), rc);
616
- if( rc!=TH_OK ){
617
- return rc;
618
- }
619556
 Tcl_Preserve((ClientData)tclInterp);
620557
 #if !defined(USE_TCL_EVALOBJV) || !USE_TCL_EVALOBJV
621558
 if( GET_CTX_TCL_USEOBJPROC(ctx) ){
622559
 Tcl_Command command;
623560
 Tcl_CmdInfo cmdInfo;
@@ -649,12 +586,10 @@
649586
 FREE_ARGV_TO_OBJV();
650587
 }
651588
 zResult = getTclResult(tclInterp, &nResult);
652589
 Th_SetResult(interp, zResult, nResult);
653590
 Tcl_Release((ClientData)tclInterp);
654
- rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, TH1_LEN(argl),
655
- getTh1ReturnCode(rc));
656591
 return rc;
657592
 }
658593
659594
 /*
660595
 ** TH1 command: tclIsSafe
@@ -767,10 +702,11 @@
767702
 int objc,
768703
 Tcl_Obj *const objv[]
769704
 ){
770705
 Th_Interp *th1Interp;
771706
 int nArg;
707
+ Tcl_Size szArg;
772708
 const char *arg;
773709
 int rc;
774710
775711
 if( objc!=2 ){
776712
 Tcl_WrongNumArgs(interp, 1, objv, "arg");
@@ -779,11 +715,12 @@
779715
 th1Interp = (Th_Interp *)clientData;
780716
 if( !th1Interp ){
781717
 Tcl_AppendResult(interp, "invalid TH1 interpreter", NULL);
782718
 return TCL_ERROR;
783719
 }
784
- arg = Tcl_GetStringFromObj(objv[1], &nArg);
720
+ arg = Tcl_GetStringFromObj(objv[1], &szArg);
721
+ nArg = (int)szArg;
785722
 rc = Th_Eval(th1Interp, 0, arg, nArg);
786723
 arg = Th_GetResult(th1Interp, &nArg);
787724
 Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, TH1_LEN(nArg)));
788725
 return getTclReturnCode(rc);
789726
 }
@@ -800,10 +737,11 @@
800737
 int objc,
801738
 Tcl_Obj *const objv[]
802739
 ){
803740
 Th_Interp *th1Interp;
804741
 int nArg;
742
+ Tcl_Size szArg;
805743
 const char *arg;
806744
 int rc;
807745
808746
 if( objc!=2 ){
809747
 Tcl_WrongNumArgs(interp, 1, objv, "arg");
@@ -812,12 +750,12 @@
812750
 th1Interp = (Th_Interp *)clientData;
813751
 if( !th1Interp ){
814752
 Tcl_AppendResult(interp, "invalid TH1 interpreter", NULL);
815753
 return TCL_ERROR;
816754
 }
817
- arg = Tcl_GetStringFromObj(objv[1], &nArg);
818
- rc = Th_Expr(th1Interp, arg, nArg);
755
+ arg = Tcl_GetStringFromObj(objv[1], &szArg);
756
+ rc = Th_Expr(th1Interp, arg, (int)szArg);
819757
 arg = Th_GetResult(th1Interp, &nArg);
820758
 Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, TH1_LEN(nArg)));
821759
 return getTclReturnCode(rc);
822760
 }
823761
824762
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -183,11 +183,11 @@
183 ** the only Tcl API functions that MUST be called prior to being able to call
184 ** Tcl_InitStubs (i.e. because it requires a Tcl interpreter). For complete
185 ** cleanup if the Tcl stubs initialization fails somehow, the Tcl_DeleteInterp
186 ** and Tcl_Finalize function types are also required.
187 */
188 typedef void (tcl_FindExecutableProc) (const char *);
189 typedef Tcl_Interp *(tcl_CreateInterpProc) (void);
190 typedef void (tcl_DeleteInterpProc) (Tcl_Interp *);
191 typedef void (tcl_FinalizeProc) (void);
192
193 /*
@@ -321,27 +321,10 @@
321 ** by the caller. This must be declared here because quite a few functions in
322 ** this file need to use it before it can be defined.
323 */
324 static int createTclInterp(Th_Interp *interp, void *pContext);
325
326 /*
327 ** Returns the TH1 return code corresponding to the specified Tcl
328 ** return code.
329 */
330 static int getTh1ReturnCode(
331 int rc /* The Tcl return code value to convert. */
332 ){
333 switch( rc ){
334 case /*0*/ TCL_OK: return /*0*/ TH_OK;
335 case /*1*/ TCL_ERROR: return /*1*/ TH_ERROR;
336 case /*2*/ TCL_RETURN: return /*3*/ TH_RETURN;
337 case /*3*/ TCL_BREAK: return /*2*/ TH_BREAK;
338 case /*4*/ TCL_CONTINUE: return /*4*/ TH_CONTINUE;
339 default /*?*/: return /*?*/ rc;
340 }
341 }
342
343 /*
344 ** Returns the Tcl return code corresponding to the specified TH1
345 ** return code.
346 */
347 static int getTclReturnCode(
@@ -387,10 +370,12 @@
387 static char *getTclResult(
388 Tcl_Interp *pInterp,
389 int *pN
390 ){
391 Tcl_Obj *resultPtr;
 
 
392
393 if( !pInterp ){ /* This should not happen. */
394 if( pN ) *pN = 0;
395 return 0;
396 }
@@ -397,11 +382,13 @@
397 resultPtr = Tcl_GetObjResult(pInterp);
398 if( !resultPtr ){ /* This should not happen either? */
399 if( pN ) *pN = 0;
400 return 0;
401 }
402 return Tcl_GetStringFromObj(resultPtr, pN);
 
 
403 }
404
405 /*
406 ** Tcl context information used by TH1. This structure definition has been
407 ** copied from and should be kept in sync with the one in "main.c".
@@ -416,48 +403,12 @@
416 tcl_FinalizeProc *xFinalize; /* Tcl_Finalize() pointer. */
417 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
418 int useObjProc; /* Non-zero if an objProc can be called directly. */
419 int useTip285; /* Non-zero if TIP #285 is available. */
420 const char *setup; /* The optional Tcl setup script. */
421 tcl_NotifyProc *xPreEval; /* Optional, called before Tcl_Eval*(). */
422 void *pPreContext; /* Optional, provided to xPreEval(). */
423 tcl_NotifyProc *xPostEval; /* Optional, called after Tcl_Eval*(). */
424 void *pPostContext; /* Optional, provided to xPostEval(). */
425 };
426
427 /*
428 ** This function calls the configured xPreEval or xPostEval functions, if any.
429 ** May have arbitrary side-effects. This function returns the result of the
430 ** called notification function or the value of the rc argument if there is no
431 ** notification function configured.
432 */
433 static int notifyPreOrPostEval(
434 int bIsPost,
435 Th_Interp *interp,
436 void *ctx,
437 int argc,
438 const char **argv,
439 int *argl,
440 int rc
441 ){
442 struct TclContext *tclContext = (struct TclContext *)ctx;
443 tcl_NotifyProc *xNotifyProc;
444
445 if( !tclContext ){
446 Th_ErrorMessage(interp,
447 "invalid Tcl context", (const char *)"", 0);
448 return TH_ERROR;
449 }
450 xNotifyProc = bIsPost ? tclContext->xPostEval : tclContext->xPreEval;
451 if( xNotifyProc ){
452 rc = xNotifyProc(bIsPost ?
453 tclContext->pPostContext : tclContext->pPreContext,
454 interp, ctx, argc, argv, TH1_LEN(argl), rc);
455 }
456 return rc;
457 }
458
459 /*
460 ** TH1 command: tclEval arg ?arg ...?
461 **
462 ** Evaluates the Tcl script and returns its result verbatim. If a Tcl script
463 ** error is generated, it will be transformed into a TH1 script error. The
@@ -485,14 +436,10 @@
485 tclInterp = GET_CTX_TCL_INTERP(ctx);
486 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
487 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
488 return TH_ERROR;
489 }
490 rc = notifyPreOrPostEval(0, interp, ctx, argc, argv, TH1_LEN(argl), rc);
491 if( rc!=TH_OK ){
492 return rc;
493 }
494 Tcl_Preserve((ClientData)tclInterp);
495 if( argc==2 ){
496 objPtr = Tcl_NewStringObj(argv[1], TH1_LEN(argl[1]));
497 Tcl_IncrRefCount(objPtr);
498 rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
@@ -507,12 +454,10 @@
507 FREE_ARGV_TO_OBJV();
508 }
509 zResult = getTclResult(tclInterp, &nResult);
510 Th_SetResult(interp, zResult, nResult);
511 Tcl_Release((ClientData)tclInterp);
512 rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, TH1_LEN(argl),
513 getTh1ReturnCode(rc));
514 return rc;
515 }
516
517 /*
518 ** TH1 command: tclExpr arg ?arg ...?
@@ -545,14 +490,10 @@
545 tclInterp = GET_CTX_TCL_INTERP(ctx);
546 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
547 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
548 return TH_ERROR;
549 }
550 rc = notifyPreOrPostEval(0, interp, ctx, argc, argv, TH1_LEN(argl), rc);
551 if( rc!=TH_OK ){
552 return rc;
553 }
554 Tcl_Preserve((ClientData)tclInterp);
555 if( argc==2 ){
556 objPtr = Tcl_NewStringObj(argv[1], TH1_LEN(argl[1]));
557 Tcl_IncrRefCount(objPtr);
558 rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
@@ -565,21 +506,21 @@
565 rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
566 Tcl_DecrRefCount(objPtr); objPtr = 0;
567 FREE_ARGV_TO_OBJV();
568 }
569 if( rc==TCL_OK ){
570 zResult = Tcl_GetStringFromObj(resultObjPtr, &nResult);
 
 
571 }else{
572 zResult = getTclResult(tclInterp, &nResult);
573 }
574 Th_SetResult(interp, zResult, nResult);
575 if( rc==TCL_OK ){
576 Tcl_DecrRefCount(resultObjPtr); resultObjPtr = 0;
577 }
578 Tcl_Release((ClientData)tclInterp);
579 rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, TH1_LEN(argl),
580 getTh1ReturnCode(rc));
581 return rc;
582 }
583
584 /*
585 ** TH1 command: tclInvoke command ?arg ...?
@@ -610,14 +551,10 @@
610 tclInterp = GET_CTX_TCL_INTERP(ctx);
611 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
612 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
613 return TH_ERROR;
614 }
615 rc = notifyPreOrPostEval(0, interp, ctx, argc, argv, TH1_LEN(argl), rc);
616 if( rc!=TH_OK ){
617 return rc;
618 }
619 Tcl_Preserve((ClientData)tclInterp);
620 #if !defined(USE_TCL_EVALOBJV) || !USE_TCL_EVALOBJV
621 if( GET_CTX_TCL_USEOBJPROC(ctx) ){
622 Tcl_Command command;
623 Tcl_CmdInfo cmdInfo;
@@ -649,12 +586,10 @@
649 FREE_ARGV_TO_OBJV();
650 }
651 zResult = getTclResult(tclInterp, &nResult);
652 Th_SetResult(interp, zResult, nResult);
653 Tcl_Release((ClientData)tclInterp);
654 rc = notifyPreOrPostEval(1, interp, ctx, argc, argv, TH1_LEN(argl),
655 getTh1ReturnCode(rc));
656 return rc;
657 }
658
659 /*
660 ** TH1 command: tclIsSafe
@@ -767,10 +702,11 @@
767 int objc,
768 Tcl_Obj *const objv[]
769 ){
770 Th_Interp *th1Interp;
771 int nArg;
 
772 const char *arg;
773 int rc;
774
775 if( objc!=2 ){
776 Tcl_WrongNumArgs(interp, 1, objv, "arg");
@@ -779,11 +715,12 @@
779 th1Interp = (Th_Interp *)clientData;
780 if( !th1Interp ){
781 Tcl_AppendResult(interp, "invalid TH1 interpreter", NULL);
782 return TCL_ERROR;
783 }
784 arg = Tcl_GetStringFromObj(objv[1], &nArg);
 
785 rc = Th_Eval(th1Interp, 0, arg, nArg);
786 arg = Th_GetResult(th1Interp, &nArg);
787 Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, TH1_LEN(nArg)));
788 return getTclReturnCode(rc);
789 }
@@ -800,10 +737,11 @@
800 int objc,
801 Tcl_Obj *const objv[]
802 ){
803 Th_Interp *th1Interp;
804 int nArg;
 
805 const char *arg;
806 int rc;
807
808 if( objc!=2 ){
809 Tcl_WrongNumArgs(interp, 1, objv, "arg");
@@ -812,12 +750,12 @@
812 th1Interp = (Th_Interp *)clientData;
813 if( !th1Interp ){
814 Tcl_AppendResult(interp, "invalid TH1 interpreter", NULL);
815 return TCL_ERROR;
816 }
817 arg = Tcl_GetStringFromObj(objv[1], &nArg);
818 rc = Th_Expr(th1Interp, arg, nArg);
819 arg = Th_GetResult(th1Interp, &nArg);
820 Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, TH1_LEN(nArg)));
821 return getTclReturnCode(rc);
822 }
823
824
--- src/th_tcl.c
+++ src/th_tcl.c
@@ -183,11 +183,11 @@
183 ** the only Tcl API functions that MUST be called prior to being able to call
184 ** Tcl_InitStubs (i.e. because it requires a Tcl interpreter). For complete
185 ** cleanup if the Tcl stubs initialization fails somehow, the Tcl_DeleteInterp
186 ** and Tcl_Finalize function types are also required.
187 */
188 typedef const char *(tcl_FindExecutableProc) (const char *);
189 typedef Tcl_Interp *(tcl_CreateInterpProc) (void);
190 typedef void (tcl_DeleteInterpProc) (Tcl_Interp *);
191 typedef void (tcl_FinalizeProc) (void);
192
193 /*
@@ -321,27 +321,10 @@
321 ** by the caller. This must be declared here because quite a few functions in
322 ** this file need to use it before it can be defined.
323 */
324 static int createTclInterp(Th_Interp *interp, void *pContext);
325
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
326 /*
327 ** Returns the Tcl return code corresponding to the specified TH1
328 ** return code.
329 */
330 static int getTclReturnCode(
@@ -387,10 +370,12 @@
370 static char *getTclResult(
371 Tcl_Interp *pInterp,
372 int *pN
373 ){
374 Tcl_Obj *resultPtr;
375 Tcl_Size n;
376 char *zRes;
377
378 if( !pInterp ){ /* This should not happen. */
379 if( pN ) *pN = 0;
380 return 0;
381 }
@@ -397,11 +382,13 @@
382 resultPtr = Tcl_GetObjResult(pInterp);
383 if( !resultPtr ){ /* This should not happen either? */
384 if( pN ) *pN = 0;
385 return 0;
386 }
387 zRes = Tcl_GetStringFromObj(resultPtr, &n);
388 *pN = (int)n;
389 return zRes;
390 }
391
392 /*
393 ** Tcl context information used by TH1. This structure definition has been
394 ** copied from and should be kept in sync with the one in "main.c".
@@ -416,48 +403,12 @@
403 tcl_FinalizeProc *xFinalize; /* Tcl_Finalize() pointer. */
404 Tcl_Interp *interp; /* The on-demand created Tcl interpreter. */
405 int useObjProc; /* Non-zero if an objProc can be called directly. */
406 int useTip285; /* Non-zero if TIP #285 is available. */
407 const char *setup; /* The optional Tcl setup script. */
 
 
 
 
408 };
409
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
410 /*
411 ** TH1 command: tclEval arg ?arg ...?
412 **
413 ** Evaluates the Tcl script and returns its result verbatim. If a Tcl script
414 ** error is generated, it will be transformed into a TH1 script error. The
@@ -485,14 +436,10 @@
436 tclInterp = GET_CTX_TCL_INTERP(ctx);
437 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
438 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
439 return TH_ERROR;
440 }
 
 
 
 
441 Tcl_Preserve((ClientData)tclInterp);
442 if( argc==2 ){
443 objPtr = Tcl_NewStringObj(argv[1], TH1_LEN(argl[1]));
444 Tcl_IncrRefCount(objPtr);
445 rc = Tcl_EvalObjEx(tclInterp, objPtr, 0);
@@ -507,12 +454,10 @@
454 FREE_ARGV_TO_OBJV();
455 }
456 zResult = getTclResult(tclInterp, &nResult);
457 Th_SetResult(interp, zResult, nResult);
458 Tcl_Release((ClientData)tclInterp);
 
 
459 return rc;
460 }
461
462 /*
463 ** TH1 command: tclExpr arg ?arg ...?
@@ -545,14 +490,10 @@
490 tclInterp = GET_CTX_TCL_INTERP(ctx);
491 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
492 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
493 return TH_ERROR;
494 }
 
 
 
 
495 Tcl_Preserve((ClientData)tclInterp);
496 if( argc==2 ){
497 objPtr = Tcl_NewStringObj(argv[1], TH1_LEN(argl[1]));
498 Tcl_IncrRefCount(objPtr);
499 rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
@@ -565,21 +506,21 @@
506 rc = Tcl_ExprObj(tclInterp, objPtr, &resultObjPtr);
507 Tcl_DecrRefCount(objPtr); objPtr = 0;
508 FREE_ARGV_TO_OBJV();
509 }
510 if( rc==TCL_OK ){
511 Tcl_Size szResult = 0;
512 zResult = Tcl_GetStringFromObj(resultObjPtr, &szResult);
513 nResult = (int)szResult;
514 }else{
515 zResult = getTclResult(tclInterp, &nResult);
516 }
517 Th_SetResult(interp, zResult, (int)nResult);
518 if( rc==TCL_OK ){
519 Tcl_DecrRefCount(resultObjPtr); resultObjPtr = 0;
520 }
521 Tcl_Release((ClientData)tclInterp);
 
 
522 return rc;
523 }
524
525 /*
526 ** TH1 command: tclInvoke command ?arg ...?
@@ -610,14 +551,10 @@
551 tclInterp = GET_CTX_TCL_INTERP(ctx);
552 if( !tclInterp || Tcl_InterpDeleted(tclInterp) ){
553 Th_ErrorMessage(interp, "invalid Tcl interpreter", (const char *)"", 0);
554 return TH_ERROR;
555 }
 
 
 
 
556 Tcl_Preserve((ClientData)tclInterp);
557 #if !defined(USE_TCL_EVALOBJV) || !USE_TCL_EVALOBJV
558 if( GET_CTX_TCL_USEOBJPROC(ctx) ){
559 Tcl_Command command;
560 Tcl_CmdInfo cmdInfo;
@@ -649,12 +586,10 @@
586 FREE_ARGV_TO_OBJV();
587 }
588 zResult = getTclResult(tclInterp, &nResult);
589 Th_SetResult(interp, zResult, nResult);
590 Tcl_Release((ClientData)tclInterp);
 
 
591 return rc;
592 }
593
594 /*
595 ** TH1 command: tclIsSafe
@@ -767,10 +702,11 @@
702 int objc,
703 Tcl_Obj *const objv[]
704 ){
705 Th_Interp *th1Interp;
706 int nArg;
707 Tcl_Size szArg;
708 const char *arg;
709 int rc;
710
711 if( objc!=2 ){
712 Tcl_WrongNumArgs(interp, 1, objv, "arg");
@@ -779,11 +715,12 @@
715 th1Interp = (Th_Interp *)clientData;
716 if( !th1Interp ){
717 Tcl_AppendResult(interp, "invalid TH1 interpreter", NULL);
718 return TCL_ERROR;
719 }
720 arg = Tcl_GetStringFromObj(objv[1], &szArg);
721 nArg = (int)szArg;
722 rc = Th_Eval(th1Interp, 0, arg, nArg);
723 arg = Th_GetResult(th1Interp, &nArg);
724 Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, TH1_LEN(nArg)));
725 return getTclReturnCode(rc);
726 }
@@ -800,10 +737,11 @@
737 int objc,
738 Tcl_Obj *const objv[]
739 ){
740 Th_Interp *th1Interp;
741 int nArg;
742 Tcl_Size szArg;
743 const char *arg;
744 int rc;
745
746 if( objc!=2 ){
747 Tcl_WrongNumArgs(interp, 1, objv, "arg");
@@ -812,12 +750,12 @@
750 th1Interp = (Th_Interp *)clientData;
751 if( !th1Interp ){
752 Tcl_AppendResult(interp, "invalid TH1 interpreter", NULL);
753 return TCL_ERROR;
754 }
755 arg = Tcl_GetStringFromObj(objv[1], &szArg);
756 rc = Th_Expr(th1Interp, arg, (int)szArg);
757 arg = Th_GetResult(th1Interp, &nArg);
758 Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, TH1_LEN(nArg)));
759 return getTclReturnCode(rc);
760 }
761
762

Keyboard Shortcuts

Open search /
Next entry (timeline) j
Previous entry (timeline) k
Open focused entry Enter
Show this help ?
Toggle theme Top nav button